diff --git a/README.md b/README.md --- a/README.md +++ b/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 @@ | `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/purescript-cst.cabal b/purescript-cst.cabal --- a/purescript-cst.cabal +++ b/purescript-cst.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: purescript-cst -version: 0.1.1.0 +version: 0.2.0.0 license: BSD-3-Clause license-file: LICENSE copyright: @@ -14,13 +14,10 @@ homepage: http://www.purescript.org/ bug-reports: https://github.com/purescript/purescript/issues 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 build-type: Simple -extra-source-files: - tests/purs/**/*.out - tests/purs/**/*.purs - README.md +extra-source-files: README.md source-repository head type: git @@ -28,6 +25,17 @@ library 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 @@ -41,6 +49,17 @@ 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 build-tool-depends: happy:happy ==1.20.0 hs-source-dirs: src @@ -62,49 +81,20 @@ ghc-options: -Wall build-depends: - 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.1.0, - scientific >=0.3.6.2 && <0.4, - semigroups >=0.19.1 && <0.20, - text >=1.2.4.1 && <1.3 - -test-suite tests - type: exitcode-stdio-1.0 - main-is: Main.hs - build-tool-depends: happy:happy ==1.20.0 - hs-source-dirs: tests - other-modules: - TestCst - Paths_purescript_cst - - 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 - - ghc-options: -Wall - 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, - base-compat >=0.11.2 && <0.12, - purescript-cst -any, - bytestring >=0.10.12.0 && <0.11, - filepath >=1.4.2.1 && <1.5, - tasty >=1.2.3 && <1.3, - tasty-golden >=2.3.3.2 && <2.4, - tasty-quickcheck >=0.10.1.2 && <0.11 + serialise >=0.2.3.0 && <0.3, + vector >=0.12.1.2 && <0.13 diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Supply.hs @@ -0,0 +1,31 @@ +-- | +-- Fresh variable supply +-- +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 +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) + +runSupplyT :: Integer -> SupplyT m a -> m (a, Integer) +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/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Supply/Class.hs @@ -0,0 +1,33 @@ +-- | +-- 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 +import Control.Monad.Writer +import Data.Text (Text, pack) + +class Monad m => MonadSupply m where + fresh :: m Integer + peek :: m Integer + default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer + fresh = lift fresh + default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => 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) +instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) + +freshName :: MonadSupply m => m Text +freshName = fmap (("$" <> ) . pack . show) fresh diff --git a/src/Language/PureScript/AST.hs b/src/Language/PureScript/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST.hs @@ -0,0 +1,14 @@ +-- | +-- 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/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Binders.hs @@ -0,0 +1,159 @@ +-- | +-- Case binders +-- +module Language.PureScript.AST.Binders where + +import Prelude.Compat + +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 +-- +data Binder + -- | + -- Wildcard binder + -- + = NullBinder + -- | + -- A binder which matches a literal + -- + | LiteralBinder SourceSpan (Literal Binder) + -- | + -- A binder which binds an identifier + -- + | VarBinder SourceSpan Ident + -- | + -- A binder which matches a data constructor + -- + | ConstructorBinder SourceSpan (Qualified (ProperName 'ConstructorName)) [Binder] + -- | + -- A operator alias binder. During the rebracketing phase of desugaring, + -- this data constructor will be removed. + -- + | OpBinder SourceSpan (Qualified (OpName 'ValueOpName)) + -- | + -- 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 binds its input to an identifier + -- + | NamedBinder SourceSpan Ident Binder + -- | + -- A binder with source position information + -- + | PositionedBinder SourceSpan [Comment] Binder + -- | + -- A binder with a type annotation + -- + | TypedBinder SourceType 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 `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. +instance Eq Binder where + 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 (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 (OpBinder _ qov) (OpBinder _ qov') = + compare qov qov' + compare (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = + compare b1 b1' <> compare b2 b2' <> compare b3 b3' + compare (ParensInBinder b) (ParensInBinder b') = + compare b b' + compare (NamedBinder _ ident b) (NamedBinder _ ident' b') = + compare ident ident' <> compare b b' + compare (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = + compare comments comments' <> compare b b' + compare (TypedBinder ty b) (TypedBinder ty' b') = + compare ty ty' <> compare b b' + 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 +-- +binderNames :: Binder -> [Ident] +binderNames = map snd . binderNamesWithSpans + +binderNamesWithSpans :: Binder -> [(SourceSpan, Ident)] +binderNamesWithSpans = go [] + where + go ns (LiteralBinder _ b) = lit ns b + 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 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 + 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 new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Declarations.hs @@ -0,0 +1,843 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Data types for modules and declarations +-- +module Language.PureScript.AST.Declarations where + +import Prelude.Compat +import Protolude.Exceptions (hush) + +import Codec.Serialise (Serialise) +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.AST.Declarations.ChainId (ChainId) +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)] + +-- | 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, 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 +onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f) + +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) + +-- | Error message hints, providing more detailed information about failure. +data ErrorMessageHint + = ErrorUnifyingTypes SourceType SourceType + | ErrorInExpression Expr + | ErrorInModule ModuleName + | ErrorInInstance (Qualified (ProperName 'ClassName)) [SourceType] + | ErrorInSubsumption SourceType SourceType + | ErrorCheckingAccessor Expr PSString + | ErrorCheckingType Expr SourceType + | ErrorCheckingKind SourceType SourceType + | ErrorCheckingGuard + | ErrorInferringType Expr + | ErrorInferringKind SourceType + | ErrorInApplication Expr SourceType Expr + | ErrorInDataConstructor (ProperName 'ConstructorName) + | ErrorInTypeConstructor (ProperName 'TypeName) + | ErrorInBindingGroup (NEL.NonEmpty Ident) + | ErrorInDataBindingGroup [ProperName 'TypeName] + | ErrorInTypeSynonym (ProperName 'TypeName) + | ErrorInValueDeclaration Ident + | ErrorInTypeDeclaration Ident + | ErrorInTypeClassDeclaration (ProperName 'ClassName) + | ErrorInKindDeclaration (ProperName 'TypeName) + | ErrorInRoleDeclaration (ProperName 'TypeName) + | ErrorInForeignImport Ident + | ErrorSolvingConstraint SourceConstraint + | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) + | PositionedError (NEL.NonEmpty SourceSpan) + deriving (Show) + +-- | Categories of hints +data HintCategory + = ExprHint + | KindHint + | CheckHint + | PositionHint + | SolverHint + | OtherHint + deriving (Show, Eq) + +-- | +-- A module declaration, consisting of comments about the module, a module name, +-- 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) + +-- | Return a module's name. +getModuleName :: Module -> ModuleName +getModuleName (Module _ _ name _ _) = name + +-- | Return a module's source span. +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. +-- +-- 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 = + case toImportAs of + Nothing -> True + _ -> as' == toImportAs + 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 = C.Prim + in + addDefaultImport (Qualified (Just primModName) primModName) + . addDefaultImport (Qualified Nothing primModName) + +-- | +-- An item in a list of explicit imports or exports +-- +data DeclarationRef + -- | + -- A type class + -- + = 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 + -- | + -- A value-level operator + -- + | ValueOpRef SourceSpan (OpName 'ValueOpName) + -- | + -- A type class instance, created during typeclass desugaring (name, class name, instance types) + -- + | TypeInstanceRef SourceSpan Ident + -- | + -- A module, in its entirety + -- + | ModuleRef SourceSpan ModuleName + -- | + -- A value re-exported from another module. These will be inserted during + -- elaboration in name desugaring. + -- + | ReExportRef SourceSpan ExportSource DeclarationRef + deriving (Show, Generic, NFData, Serialise) + +instance Eq DeclarationRef where + (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' + (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 + 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' + 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 TypeClassRef{} = 0 + orderOf TypeOpRef{} = 1 + orderOf TypeRef{} = 2 + orderOf ValueRef{} = 3 + orderOf ValueOpRef{} = 4 + orderOf TypeInstanceRef{} = 5 + orderOf ModuleRef{} = 6 + orderOf ReExportRef{} = 7 + +data ExportSource = + ExportSource + { exportSourceImportedFrom :: Maybe ModuleName + , exportSourceDefinedIn :: ModuleName + } + deriving (Eq, Ord, Show, Generic, NFData, Serialise) + +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 (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 (ReExportRef _ _ ref) = declRefName ref + +getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) +getTypeRef (TypeRef _ name dctors) = Just (name, dctors) +getTypeRef _ = Nothing + +getTypeOpRef :: DeclarationRef -> Maybe (OpName 'TypeOpName) +getTypeOpRef (TypeOpRef _ op) = Just op +getTypeOpRef _ = Nothing + +getValueRef :: DeclarationRef -> Maybe Ident +getValueRef (ValueRef _ name) = Just name +getValueRef _ = Nothing + +getValueOpRef :: DeclarationRef -> Maybe (OpName 'ValueOpName) +getValueOpRef (ValueOpRef _ op) = Just op +getValueOpRef _ = Nothing + +getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName) +getTypeClassRef (TypeClassRef _ name) = Just name +getTypeClassRef _ = Nothing + +isModuleRef :: DeclarationRef -> Bool +isModuleRef ModuleRef{} = True +isModuleRef _ = False + +-- | +-- The data type which specifies type of import declaration +-- +data ImportDeclarationType + -- | + -- An import with no explicit list: `import M`. + -- + = Implicit + -- | + -- An import with an explicit list of references to import: `import M (foo)` + -- + | Explicit [DeclarationRef] + -- | + -- An import with a list of references to hide: `import M hiding (foo)` + -- + | Hiding [DeclarationRef] + deriving (Eq, Show, Generic, Serialise) + +isImplicit :: ImportDeclarationType -> Bool +isImplicit Implicit = True +isImplicit _ = False + +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@ +-- +-- In this example @identity@ is the identifier and @forall a. a -> a@ the type. +data TypeDeclarationData = TypeDeclarationData + { tydeclSourceAnn :: !SourceAnn + , tydeclIdent :: !Ident + , 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 + +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). +-- +-- @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 + +pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration +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) + +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 + +-- | +-- The data type of declarations +-- +data Declaration + -- | + -- A data type declaration (data or newtype, name, arguments, data constructors) + -- + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceType)] [DataConstructorDeclaration] + -- | + -- A minimal mutually recursive set of data type declarations + -- + | DataBindingGroupDeclaration (NEL.NonEmpty Declaration) + -- | + -- A type synonym declaration (name, arguments, type) + -- + | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceType)] SourceType + -- | + -- A kind signature declaration + -- + | KindDeclaration SourceAnn KindSignatureFor (ProperName 'TypeName) SourceType + -- | + -- A role declaration (name, roles) + -- + | RoleDeclaration {-# UNPACK #-} !RoleDeclarationData + -- | + -- A type declaration for a value (name, ty) + -- + | TypeDeclaration {-# UNPACK #-} !TypeDeclarationData + -- | + -- A value declaration (name, top-level binders, optional guard, value) + -- + | ValueDeclaration {-# UNPACK #-} !(ValueDeclarationData [GuardedExpr]) + -- | + -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value) + | BoundValueDeclaration SourceAnn Binder Expr + -- | + -- A minimal mutually recursive set of value declarations + -- + | BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr)) + -- | + -- A foreign import declaration (name, type) + -- + | ExternDeclaration SourceAnn Ident SourceType + -- | + -- A data type foreign import (name, kind) + -- + | ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceType + -- | + -- A fixity declaration + -- + | FixityDeclaration SourceAnn (Either ValueFixity TypeFixity) + -- | + -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) + -- + | ImportDeclaration SourceAnn ModuleName ImportDeclarationType (Maybe ModuleName) + -- | + -- A type class declaration (name, argument, implies, member declarations) + -- + | 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) + -- + | 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) + deriving (Eq, Ord, Show) + +data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) + deriving (Eq, Ord, Show) + +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 :: 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 + = 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) + +mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody +mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) + +-- | A traversal for TypeInstanceBody +traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody +traverseTypeInstanceBody 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 +declSourceAnn (BoundValueDeclaration sa _ _) = sa +declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa +declSourceAnn (ExternDeclaration sa _ _) = sa +declSourceAnn (ExternDataDeclaration sa _ _) = sa +declSourceAnn (FixityDeclaration sa _) = sa +declSourceAnn (ImportDeclaration sa _ _ _) = sa +declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa +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 vd) = Just (IdentName (valdeclIdent vd)) +declName (ExternDeclaration _ n _) = Just (IdentName n) +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 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 +-- +isValueDecl :: Declaration -> Bool +isValueDecl ValueDeclaration{} = True +isValueDecl _ = False + +-- | +-- Test if a declaration is a data type declaration +-- +isDataDecl :: Declaration -> Bool +isDataDecl DataDeclaration{} = 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 +-- +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 +-- +isExternDataDecl :: Declaration -> Bool +isExternDataDecl ExternDataDeclaration{} = True +isExternDataDecl _ = False + +-- | +-- Test if a declaration is a fixity declaration +-- +isFixityDecl :: Declaration -> Bool +isFixityDecl FixityDeclaration{} = True +isFixityDecl _ = False + +getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity) +getFixityDecl (FixityDeclaration _ fixity) = Just fixity +getFixityDecl _ = Nothing + +-- | +-- Test if a declaration is a foreign import +-- +isExternDecl :: Declaration -> Bool +isExternDecl ExternDeclaration{} = True +isExternDecl _ = False + +-- | +-- Test if a declaration is a type class instance declaration +-- +isTypeClassInstanceDecl :: Declaration -> Bool +isTypeClassInstanceDecl TypeInstanceDeclaration{} = True +isTypeClassInstanceDecl _ = False + +-- | +-- Test if a declaration is a type class declaration +-- +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 +flattenDecls :: [Declaration] -> [Declaration] +flattenDecls = concatMap flattenOne + where flattenOne :: Declaration -> [Declaration] + flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls + flattenOne d = [d] + +-- | +-- A guard is just a boolean-valued expression that appears alongside a set of binders +-- +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 +-- +data Expr + -- | + -- A literal value + -- + = Literal SourceSpan (Literal Expr) + -- | + -- A prefix -, will be desugared + -- + | UnaryMinus SourceSpan Expr + -- | + -- Binary operator application. During the rebracketing phase of desugaring, this data constructor + -- will be removed. + -- + | 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 + -- | + -- 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 PSString Expr + -- | + -- Partial record update + -- + | 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 (PathTree Expr) + -- | + -- Function introduction + -- + | Abs Binder Expr + -- | + -- Function application + -- + | 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) + -- | + -- An operator. This will be desugared into a function during the "operators" + -- phase of desugaring. + -- + | Op SourceSpan (Qualified (OpName 'ValueOpName)) + -- | + -- Conditional (if-then-else expression) + -- + | IfThenElse Expr Expr Expr + -- | + -- A data constructor + -- + | 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. + -- + | Case [Expr] [CaseAlternative] + -- | + -- A value with a type annotation + -- + | TypedValue Bool Expr SourceType + -- | + -- A let binding + -- + | Let WhereProvenance [Declaration] Expr + -- | + -- A do-notation block + -- + | Do (Maybe ModuleName) [DoNotationElement] + -- | + -- An ado-notation block + -- + | 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 + -- at superclass implementations when searching for a dictionary, the type class name and + -- 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)))) + [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] + -- | + -- A placeholder for an anonymous function argument + -- + | AnonymousArgument + -- | + -- A typed hole that will be turned into a hint/error during typechecking + -- + | Hole Text + -- | + -- A value with source position information + -- + | 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 +-- +data CaseAlternative = CaseAlternative + { -- | + -- A collection of binders with which to match the inputs + -- + caseAlternativeBinders :: [Binder] + -- | + -- The result expression or a collect of guarded expressions + -- + , caseAlternativeResult :: [GuardedExpr] + } deriving (Show) + +-- | +-- A statement in a do-notation block +-- +data DoNotationElement + -- | + -- A monadic value without a binder + -- + = DoNotationValue Expr + -- | + -- A monadic value with a binder + -- + | DoNotationBind Binder Expr + -- | + -- A let statement, i.e. a pure value with a binder + -- + | DoNotationLet [Declaration] + -- | + -- A do notation element with source position information + -- + | 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) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource) + +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 (TypedValue _ e _) = isTrueExpr e +isTrueExpr (PositionedValue _ _ e) = isTrueExpr e +isTrueExpr _ = False diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs new file mode 100644 --- /dev/null +++ b/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/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Exported.hs @@ -0,0 +1,156 @@ +module Language.PureScript.AST.Exported + ( exportedDeclarations + , isExported + ) where + +import Prelude.Compat +import Protolude (sortOn) + +import Control.Category ((>>>)) + +import Data.Maybe (mapMaybe) +import qualified Data.Map as M + +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. +-- This function descends into data declarations to filter out unexported +-- data constructors, and also filters out type instance declarations if +-- they refer to classes or types which are not themselves exported. +-- +-- Note that this function assumes that the module has already had its imports +-- desugared using 'Language.PureScript.Sugar.Names.desugarImports'. It will +-- 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 + go = flattenDecls + >>> 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. +-- If the supplied declaration is not a data declaration, this function returns +-- it unchanged. +-- +filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration +filterDataConstructors exps (DataDeclaration sa dType tyName tyArgs dctors) = + DataDeclaration sa dType tyName tyArgs $ + filter (isDctorExported tyName exps . dataCtorName) dctors +filterDataConstructors _ other = other + +-- | +-- Filter out all the type instances from a list of declarations which +-- reference a type or type class which is both local and not exported. +-- +-- Note that this function assumes that the module has already had its imports +-- desugared using "Language.PureScript.Sugar.Names.desugarImports". It will +-- produce incorrect results if this is not the case - for example, type class +-- instances will be incorrectly removed in some cases. +-- +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 + -- classes, returns whether the supplied Qualified ProperName is visible + -- outside this module. This is true if one of the following hold: + -- + -- * 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 + :: [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 _ = Nothing + + typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName) + typeClassName (TypeClassRef _ n) = Just n + typeClassName _ = Nothing + +-- | +-- 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 _) = + Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) + where + + fromConstraint c = Left (constraintClass c) : concatMap fromType (constraintArgs c) + fromType = everythingOnTypes (++) go + + -- 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 _ = [] + +typeInstanceConstituents _ = [] + + +-- | +-- Test if a declaration is exported, given a module's export list. Note that +-- this function does not account for type instance declarations of +-- non-exported types, or non-exported data constructors. Therefore, you should +-- prefer 'exportedDeclarations' to this function, where possible. +-- +isExported :: Maybe [DeclarationRef] -> Declaration -> Bool +isExported Nothing _ = True +isExported _ TypeInstanceDeclaration{} = True +isExported (Just exps) decl = any matches exps + where + matches declRef = declName decl == Just (declRefName declRef) + +-- | +-- 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 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool +isDctorExported _ Nothing _ = True +isDctorExported ident (Just exps) ctor = test `any` exps + where + 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 = + sortOn 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/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Literals.hs @@ -0,0 +1,38 @@ +-- | +-- The core functional representation for literal values. +-- +module Language.PureScript.AST.Literals where + +import Prelude.Compat +import Language.PureScript.PSString (PSString) + +-- | +-- Data type for literal values. Parameterised so it can be used for Exprs and +-- Binders. +-- +data Literal a + -- | + -- A numeric literal + -- + = NumericLiteral (Either Integer Double) + -- | + -- A string literal + -- + | StringLiteral PSString + -- | + -- A character literal + -- + | CharLiteral Char + -- | + -- A boolean literal + -- + | BooleanLiteral Bool + -- | + -- An array literal + -- + | ArrayLiteral [a] + -- | + -- An object literal + -- + | ObjectLiteral [(PSString, a)] + deriving (Eq, Ord, Show, Functor) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Operators.hs @@ -0,0 +1,60 @@ +-- | +-- Operators fixity and associativity +-- +module Language.PureScript.AST.Operators where + +import Prelude.Compat + +import Codec.Serialise (Serialise) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.Aeson ((.=)) +import qualified Data.Aeson as A + +import Language.PureScript.Crash + +-- | +-- A precedence level for an infix operator +-- +type Precedence = Integer + +-- | +-- Associativity for infix operators +-- +data Associativity = Infixl | Infixr | Infix + deriving (Show, Eq, Ord, Generic) + +instance NFData Associativity +instance Serialise Associativity + +showAssoc :: Associativity -> String +showAssoc Infixl = "infixl" +showAssoc Infixr = "infixr" +showAssoc Infix = "infix" + +readAssoc :: String -> Associativity +readAssoc "infixl" = Infixl +readAssoc "infixr" = Infixr +readAssoc "infix" = Infix +readAssoc _ = internalError "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 +-- +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) = + A.object [ "associativity" .= associativity + , "precedence" .= precedence + ] diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveAnyClass #-} +-- | +-- Source position information +-- +module Language.PureScript.AST.SourcePos where + +import Prelude.Compat + +import Codec.Serialise (Serialise) +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]) + +-- | Source position information +data SourcePos = SourcePos + { sourcePosLine :: Int + -- ^ Line number + , sourcePosColumn :: Int + -- ^ Column number + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) + +displaySourcePos :: SourcePos -> Text +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] + +instance A.FromJSON SourcePos where + parseJSON arr = do + [line, col] <- A.parseJSON arr + return $ SourcePos line col + +data SourceSpan = SourceSpan + { spanName :: String + -- ^ Source name + , spanStart :: SourcePos + -- ^ Start of the span + , spanEnd :: SourcePos + -- ^ End of the span + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) + +displayStartEndPos :: SourceSpan -> Text +displayStartEndPos sp = + "(" <> + displaySourcePos (spanStart 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)) <> ":" <> + displayStartEndPosShort sp <> " " <> + displayStartEndPos sp + +instance A.ToJSON SourceSpan where + toJSON SourceSpan{..} = + A.object [ "name" .= spanName + , "start" .= spanStart + , "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) + +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 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 + 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 new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Traversals.hs @@ -0,0 +1,681 @@ +-- | +-- AST traversal helpers +-- +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.Names +import Language.PureScript.Traversals +import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) +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 (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) + -> (Expr -> Expr) + -> (Binder -> Binder) + -> ( Declaration -> Declaration + , Expr -> Expr + , Binder -> Binder + ) +everywhereOnValues f g h = (f', g', h') + where + f' :: Declaration -> Declaration + f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds)) + 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)) + 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 + 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)) + 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)) + 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) + g' (Let w ds v) = g (Let w (fmap f' ds) (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 + + h' :: Binder -> Binder + 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 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)) + h' other = h other + + lit :: (a -> a) -> Literal a -> Literal a + 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 = 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 (fmap 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) + => (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' (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 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 + f' other = f other + + g' :: Expr -> m Expr + 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') + 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 + 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 + g' (Let w ds v) = Let w <$> traverse (f' <=< f) ds <*> (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 + + h' :: Binder -> m Binder + 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') + 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 + + handleCaseAlternative :: CaseAlternative -> m CaseAlternative + handleCaseAlternative (CaseAlternative bs val) = + CaseAlternative + <$> traverse (h' <=< h) bs + <*> traverse (guardedExprM handleGuard (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 + + 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) + => (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' (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 + 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 + 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 + 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 + 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 + g' (Let w ds v) = (Let w <$> traverse f' ds <*> 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 + + h' :: Binder -> m Binder + 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 + 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 + + handleCaseAlternative :: CaseAlternative -> m CaseAlternative + handleCaseAlternative (CaseAlternative bs val) = + CaseAlternative + <$> traverse h' bs + <*> traverse (guardedExprM handleGuard 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 + + 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) + -> (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) (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@(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 + 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 = 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 _ _ = 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) + + 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 + + k' :: Guard -> r + k' (ConditionGuard e) = g' e + k' (PatternGuard b e) = h' b <>. g' e + +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 (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 -> 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 (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 (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 + 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 -> 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 (ParensInBinder b) = h'' s b + 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 (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 (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 -> 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 (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) + => 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 + + f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds + 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 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 + + 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 + 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 + 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 + g' s (Let w ds v) = Let w <$> traverse (f'' s) ds <*> 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 + + h'' s = uncurry h' <=< h s + + 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 + 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 + + 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 <*> traverse (guardedExprM (k' 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 <$> 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 + +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 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 + f'' :: S.Set ScopedIdent -> Declaration -> r + f'' s a = f s a <> f' s a + + f' :: S.Set ScopedIdent -> Declaration -> r + f' s (DataBindingGroupDeclaration 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 (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), _, _) -> 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 ScopedIdent -> Expr -> r + g'' s a = g s a <> g' s a + + 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 + 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 + g' s (Abs b v1) = + 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 + 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) = + let s' = S.union s (foldMap (fst . j'' s) es) + in g'' s' v1 + g' s (PositionedValue _ _ v1) = g'' s v1 + g' _ _ = mempty + + h'' :: S.Set ScopedIdent -> Binder -> r + h'' s a = h s a <> h' s a + + 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 (LocalIdent name) s) b1 + h' s (PositionedBinder _ _ b1) = h'' s b1 + h' s (TypedBinder _ b1) = h'' s b1 + h' _ _ = mempty + + 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 ScopedIdent -> CaseAlternative -> r + i'' s a = i s a <> i' s a + + i' :: S.Set ScopedIdent -> CaseAlternative -> r + i' s (CaseAlternative bs gs) = + let s' = S.union s (S.fromList (concatMap localBinderNames bs)) + in foldMap (h'' s) bs <> foldMap (l' s') gs + + 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 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 (localBinderNames b)) s + in (s', h'' s b <> g'' s v) + j' s (DoNotationLet 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 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 (localBinderNames 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 (ValueDeclaration vd) = Just (valdeclIdent vd) + getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td) + getDeclIdent _ = Nothing + + localBinderNames = map LocalIdent . binderNames + +accumTypes + :: (Monoid r) + => (SourceType -> r) + -> ( Declaration -> r + , Expr -> r + , Binder -> r + , CaseAlternative -> r + , DoNotationElement -> r + ) +accumTypes f = everythingOnValues mappend forDecls forValues forBinders (const mempty) (const mempty) + where + forDecls (DataDeclaration _ _ _ args dctors) = + foldMap (foldMap f . snd) args <> + foldMap (foldMap (f . snd) . dataCtorFields) dctors + forDecls (ExternDataDeclaration _ _ ty) = f ty + forDecls (ExternDeclaration _ _ ty) = f ty + forDecls (TypeClassDeclaration _ _ args implies _ _) = + foldMap (foldMap (foldMap f)) args <> + foldMap (foldMap f . constraintArgs) implies + forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = + foldMap (foldMap f . constraintArgs) cs <> foldMap f tys + forDecls (TypeSynonymDeclaration _ _ args ty) = + foldMap (foldMap f . snd) args <> + f ty + forDecls (KindDeclaration _ _ _ ty) = f ty + forDecls (TypeDeclaration td) = f (tydeclType td) + forDecls _ = mempty + + forValues (TypeClassDictionary c _ _) = foldMap f (constraintArgs c) + forValues (DeferredDictionary _ tys) = foldMap f tys + forValues (TypedValue _ _ ty) = f ty + forValues _ = mempty + + forBinders (TypedBinder ty _) = f ty + forBinders _ = mempty + +-- | +-- Map a function over type annotations appearing inside a value +-- +overTypes :: (SourceType -> SourceType) -> 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 (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/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -15,7 +15,7 @@ , comments ) where -import Prelude +import Prelude hiding (take) import Data.Bifunctor (bimap, first) import Data.Foldable (foldl', toList) @@ -24,13 +24,14 @@ 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) @@ -39,8 +40,8 @@ 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] @@ -120,7 +121,7 @@ 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 @@ -468,24 +469,24 @@ (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 @@ 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) @@ -564,7 +614,7 @@ 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/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -76,7 +76,7 @@ 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 @@ "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 @@ "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/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs --- a/src/Language/PureScript/CST/Flatten.hs +++ b/src/Language/PureScript/CST/Flatten.hs @@ -46,13 +46,12 @@ 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/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -70,7 +70,7 @@ Parser lexK = tokenAndComments - go state@(LexState {..}) = + go state@LexState {..} = lexK lexSource onError onSuccess where onError lexSource' err = do @@ -204,7 +204,7 @@ 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') @@ -332,7 +332,7 @@ 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 @@ -417,7 +417,7 @@ Just ch -> next $> (Text.singleton ch, ch) Nothing -> - throw $ ErrEof + throw ErrEof peek >>= \case Just '\'' | fromEnum ch > 0xFFFF -> throw ErrAstralCodePointInChar @@ -425,7 +425,7 @@ Just ch2 -> throw $ ErrLexeme (Just [ch2]) [] _ -> - throw $ ErrEof + throw ErrEof {- stringPart @@ -570,8 +570,8 @@ Just '0' -> next *> peek >>= \case Just ch | isNumberChar ch -> throw ErrLeadingZero _ -> pure $ Just ("0", "0") - Just ch | isDigitChar ch -> Just <$> digits - _ -> pure $ Nothing + Just ch | Char.isDigit ch -> Just <$> digits + _ -> pure Nothing {- integer1 @@ -586,10 +586,10 @@ '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 + _ -> pure Nothing {- fraction @@ -649,20 +649,20 @@ 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 b = foldl' (\n c -> n * b + (toInteger (Char.digitToInt c))) 0 +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) @@ -692,11 +692,8 @@ 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' diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs --- a/src/Language/PureScript/CST/Monad.hs +++ b/src/Language/PureScript/CST/Monad.hs @@ -2,7 +2,7 @@ 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) @@ -61,12 +61,12 @@ 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 $ 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 @@ -157,7 +157,7 @@ _ <- token open res <- go1 _ <- token close - pure $ res + pure res where go1 = oneOf $ NE.fromList @@ -179,7 +179,7 @@ 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/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -736,10 +736,14 @@ : 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/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -18,10 +18,10 @@ 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 @@ -118,10 +118,10 @@ 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 @@ 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) @@ -211,7 +211,7 @@ 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/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -261,8 +261,7 @@ 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/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -2,7 +2,7 @@ import Prelude -import Control.Monad (when) +import Control.Monad (unless) import Data.Coerce (coerce) import Data.Foldable (for_) import Data.Functor (($>)) @@ -115,12 +115,12 @@ 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" 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: " <>) @@ -128,14 +128,14 @@ 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 @@ -232,7 +232,7 @@ 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/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Comments.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Defines the types of source code comments +-- +module Language.PureScript.Comments where + +import Prelude.Compat +import Codec.Serialise (Serialise) +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, Generic) + +instance NFData Comment +instance Serialise Comment + +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment) diff --git a/src/Language/PureScript/Constants/Prim.hs b/src/Language/PureScript/Constants/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Constants/Prim.hs @@ -0,0 +1,183 @@ +-- | 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 + +-- 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 "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") + +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 +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 +pattern PrimCoerce = ModuleName "Prim.Coerce" + +pattern Coercible :: Qualified (ProperName 'ClassName) +pattern Coercible = Qualified (Just PrimCoerce) (ProperName "Coercible") + +-- Prim.Ordering + +pattern PrimOrdering :: ModuleName +pattern PrimOrdering = ModuleName "Prim.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 "Prim.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 "Prim.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 "Prim.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 "Prim.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" + +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" + +typeError :: forall a. (IsString a) => a +typeError = "TypeError" diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Crash.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} + +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") diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Environment.hs @@ -0,0 +1,630 @@ +module Language.PureScript.Environment where + +import Prelude.Compat +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 +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 + { names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) + -- ^ Values currently in scope + , 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. 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))) + -- ^ 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 + } deriving (Show, Generic) + +instance NFData Environment + +-- | Information about a type class +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. + , 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] + -- ^ 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. + , 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 + +-- | 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, Generic) + +instance NFData FunctionalDependency +instance Serialise FunctionalDependency + +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 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. +-- 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``` +-- 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. 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. +-- +-- 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 SourceType)] + -> [(Ident, SourceType)] + -> [SourceConstraint] + -> [FunctionalDependency] + -> Bool + -> 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) + +-- | The visibility of a name in scope +data NameVisibility + = Undefined + -- ^ 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, 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. +data NameKind + = Private + -- ^ 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 foreign import declaration + | External + -- ^ A name for member introduced by foreign import + deriving (Show, Eq, Generic) + +instance NFData NameKind +instance Serialise NameKind + +-- | The kinds of a type +data TypeKind + = DataType DataDeclType [(Text, Maybe SourceType, Role)] [(ProperName 'ConstructorName, [SourceType])] + -- ^ Data type + | TypeSynonym + -- ^ Type synonym + | ExternData [Role] + -- ^ Foreign data + | LocalTypeVariable + -- ^ A local type variable + | ScopedTypeVar + -- ^ A scoped type variable + deriving (Show, Eq, Generic) + +instance NFData TypeKind +instance Serialise TypeKind + +-- | The type ('data' or 'newtype') of a data type declaration +data DataDeclType + = Data + -- ^ A standard data constructor + | Newtype + -- ^ A newtype constructor + deriving (Show, Eq, Ord, Generic) + +instance NFData DataDeclType +instance Serialise DataDeclType + +showDataDeclType :: DataDeclType -> Text +showDataDeclType Data = "data" +showDataDeclType Newtype = "newtype" + +instance A.ToJSON DataDeclType where + toJSON = A.toJSON . showDataDeclType + +instance A.FromJSON DataDeclType where + 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) +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 $ 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 + +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 + +kindRowList :: SourceType -> SourceType +kindRowList = TypeApp nullSourceAnn (primSubKind C.moduleRowList C.kindRowList) + +kindRow :: SourceType -> SourceType +kindRow = TypeApp nullSourceAnn (primKind 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" + +-- | Type constructor for strings +tyString :: SourceType +tyString = primTy "String" + +-- | Type constructor for strings +tyChar :: SourceType +tyChar = primTy "Char" + +-- | Type constructor for numbers +tyNumber :: SourceType +tyNumber = primTy "Number" + +-- | Type constructor for integers +tyInt :: SourceType +tyInt = primTy "Int" + +-- | Type constructor for booleans +tyBoolean :: SourceType +tyBoolean = primTy "Boolean" + +-- | Type constructor for arrays +tyArray :: SourceType +tyArray = primTy "Array" + +-- | Type constructor for records +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 + +-- | 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 + +-- To make reading the kind signatures below easier +(-:>) :: SourceType -> SourceType -> SourceType +(-:>) = function +infixr 4 -:> + +primClass :: Qualified (ProperName 'TypeName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] +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 +-- 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)) (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 [])) + ] + +-- | This 'Map' contains all of the prim types from all Prim modules. +allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +allPrimTypes = M.unions + [ primTypes + , primBooleanTypes + , primCoerceTypes + , primOrderingTypes + , primRowTypes + , primRowListTypes + , primSymbolTypes + , primTypeErrorTypes + ] + +primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primBooleanTypes = + M.fromList + [ (primSubName C.moduleBoolean "True", (tyBoolean, ExternData [])) + , (primSubName C.moduleBoolean "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) + ] + +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 [])) + ] + +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) + ] + +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 [])) + ] <> mconcat + [ primClass (primSubName C.moduleRowList "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) + ] + +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", (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) + ] + +-- | 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 [] [] [] [] True) + ] + +-- | This contains all of the type classes from all Prim modules. +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 + -- class Coercible (a :: k) (b :: k) + [ (primSubName C.moduleCoerce "Coercible", makeTypeClassData + [ ("a", Just (tyVar "k")) + , ("b", Just (tyVar "k")) + ] [] [] [] True) + ] + +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 + [ ("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 :: Row k) (nubbed :: Row k) | original -> nubbed + , (primSubName C.moduleRow "Nub", makeTypeClassData + [ ("original", Just (kindRow (tyVar "k"))) + , ("nubbed", Just (kindRow (tyVar "k"))) + ] [] [] + [ FunctionalDependency [0] [1] + ] True) + + -- class Lacks (label :: Symbol) (row :: Row k) + , (primSubName C.moduleRow "Lacks", 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 + [ ("label", Just kindSymbol) + , ("a", Just (tyVar "k")) + , ("tail", Just (kindRow (tyVar "k"))) + , ("row", Just (kindRow (tyVar "k"))) + ] [] [] + [ FunctionalDependency [0, 1, 2] [3] + , FunctionalDependency [0, 3] [1, 2] + ] True) + ] + +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 + [ ("row", Just (kindRow (tyVar "k"))) + , ("list", Just (kindRowList (tyVar "k"))) + ] [] [] + [ FunctionalDependency [0] [1] + ] True) + ] + +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] + ] True) + + -- 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] + ] True) + + -- 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] + ] True) + ] + +primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primTypeErrorClasses = + M.fromList + -- class Fail (message :: Symbol) + [ (primSubName C.typeError "Fail", makeTypeClassData + [("message", Just kindDoc)] [] [] [] True) + + -- class Warn (message :: Symbol) + , (primSubName C.typeError "Warn", makeTypeClassData + [("message", Just kindDoc)] [] [] [] True) + ] + +-- | Finds information about data constructors from the current environment. +lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [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 '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 + +dictSynonymName' :: Text -> Text +dictSynonymName' = (<> "$Dict") + +dictSynonymName :: ProperName a -> ProperName a +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 = 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/Label.hs b/src/Language/PureScript/Label.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Label.hs @@ -0,0 +1,21 @@ +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(..)) +import qualified Data.Aeson as A + +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 { runLabel :: PSString } + deriving (Show, Eq, Ord, IsString, Semigroup, Monoid, A.ToJSON, A.FromJSON, Generic) + +instance NFData Label +instance Serialise Label diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Names.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Data types for names +-- +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) +import qualified Data.Vector as V + +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 + = IdentName Ident + | ValOpName (OpName 'ValueOpName) + | TyName (ProperName 'TypeName) + | TyOpName (OpName 'TypeOpName) + | DctorName (ProperName 'ConstructorName) + | TyClassName (ProperName 'ClassName) + | ModName ModuleName + deriving (Eq, Ord, Show, Generic) + +instance NFData Name +instance Serialise Name + +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 +-- +data Ident + -- | + -- An alphanumeric identifier + -- + = Ident Text + -- | + -- 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 +instance Serialise Ident + +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 + +freshIdent :: MonadSupply m => Text -> m Ident +freshIdent name = GenIdent (Just name) <$> fresh + +freshIdent' :: MonadSupply m => m Ident +freshIdent' = GenIdent Nothing <$> fresh + +-- | +-- Operator alias names. +-- +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 + +instance FromJSON (OpName a) where + parseJSON = fmap OpName . parseJSON + +showOp :: OpName a -> Text +showOp op = "(" <> runOpName op <> ")" + +-- | +-- The closed set of operator alias types. +-- +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. +-- +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 + +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 Text + deriving (Show, Eq, Ord, Generic) + deriving newtype Serialise + +instance NFData ModuleName + +runModuleName :: ModuleName -> Text +runModuleName (ModuleName name) = name + +moduleNameFromString :: Text -> ModuleName +moduleNameFromString = ModuleName + +isBuiltinModuleName :: ModuleName -> Bool +isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn + +-- | +-- A qualified name, i.e. a name with an optional module name +-- +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 +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 +-- +qualify :: ModuleName -> Qualified a -> (ModuleName, a) +qualify m (Qualified Nothing a) = (m, a) +qualify _ (Qualified (Just 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 + +-- | Remove the module name from a qualified 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 +-- +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 = 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) + +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 + +instance FromJSONKey ModuleName where + fromJSONKey = fmap moduleNameFromString fromJSONKey diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/PSString.hs @@ -0,0 +1,239 @@ +module Language.PureScript.PSString + ( PSString + , toUTF16CodeUnits + , decodeString + , decodeStringEither + , decodeStringWithReplacement + , prettyPrintString + , prettyPrintStringJS + , mkString + ) where + +import Prelude.Compat +import GHC.Generics (Generic) +import Codec.Serialise (Serialise) +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 +-- 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. +-- +-- 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, Semigroup, Monoid, Generic) + +instance NFData PSString +instance Serialise PSString + +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 (Char.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 +-- decoded are represented with the Right constructor. +-- +decodeStringEither :: PSString -> [Either Word16 Char] +decodeStringEither = unfoldr decode . toUTF16CodeUnits + where + 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) + +-- | +-- 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 + 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 + 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 str = + case decodeString str of + Just t -> A.toJSON t + Nothing -> A.toJSON (toUTF16CodeUnits str) + +instance A.FromJSON PSString where + parseJSON a = jsonString <|> arrayOfCodeUnits + where + 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) + + 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.ClosePunctuation + , 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. +-- +prettyPrintStringJS :: PSString -> Text +prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\"" + where + encodeChar :: Word16 -> Text + 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" + 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 + +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 + +isTrail :: Word16 -> Bool +isTrail l = l >= 0xDC00 && l <= 0xDFFF + +isSurrogate :: Word16 -> Bool +isSurrogate c = isLead c || isTrail c + +toChar :: Word16 -> Char +toChar = toEnum . fromIntegral + +toWord :: Int -> Word16 +toWord = fromIntegral + +toInt :: Word16 -> Int +toInt = fromIntegral + +mkString :: Text -> PSString +mkString = fromString . T.unpack diff --git a/src/Language/PureScript/Roles.hs b/src/Language/PureScript/Roles.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Roles.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Data types for roles. +-- +module Language.PureScript.Roles + ( Role(..) + , displayRole + ) where + +import Prelude.Compat + +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) + +-- | +-- 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 +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/Traversals.hs b/src/Language/PureScript/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Traversals.hs @@ -0,0 +1,27 @@ +-- | 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) = (, 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/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -0,0 +1,46 @@ +module Language.PureScript.TypeClassDictionaries where + +import Prelude.Compat + +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 + +-- +-- Data representing a type class dictionary which is in scope +-- +data TypeClassDictionaryInScope v + = TypeClassDictionaryInScope { + -- | The instance chain + tcdChain :: Maybe ChainId + -- | Index of the instance chain + , tcdIndex :: Integer + -- | 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 + , 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 + , tcdDependencies :: Maybe [SourceConstraint] + } + deriving (Show, Functor, Foldable, Traversable, Generic) + +instance NFData v => NFData (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) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Types.hs @@ -0,0 +1,788 @@ +-- | +-- Data types for types +-- +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) +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, 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) + +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 + +-- | +-- An identifier for the scope of a skolem variable +-- +newtype SkolemScope = SkolemScope { runSkolemScope :: Int } + deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON, Generic) + +instance NFData SkolemScope +instance Serialise SkolemScope + +-- | +-- The type of types +-- +data Type a + -- | A unification variable of type Type + = TUnknown a Int + -- | A named type variable + | TypeVar a Text + -- | A type-level string + | TypeLevelString a PSString + -- | A type wildcard, as would appear in a partial type synonym + | 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 + -- "operators" phase of desugaring. + | 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 (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 (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) (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) + -- | 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 a (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 + +srcTypeVar :: Text -> SourceType +srcTypeVar = TypeVar NullSourceAnn + +srcTypeLevelString :: PSString -> SourceType +srcTypeLevelString = TypeLevelString NullSourceAnn + +srcTypeWildcard :: SourceType +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 + +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 + +srcREmpty :: SourceType +srcREmpty = REmpty NullSourceAnn + +srcRCons :: Label -> SourceType -> SourceType -> SourceType +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)) + +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 + -- ^ 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 'Text' here because using 'Binder' would introduce a cyclic + -- dependency in the module graph. + deriving (Show, Eq, Ord, Generic) + +instance NFData ConstraintData +instance Serialise ConstraintData + +-- | A typeclass constraint +data Constraint a = Constraint + { constraintAnn :: a + -- ^ constraint annotation + , constraintClass :: Qualified (ProperName 'ClassName) + -- ^ constraint class name + , constraintKindArgs :: [Type a] + -- ^ kind arguments + , constraintArgs :: [Type a] + -- ^ type arguments + , constraintData :: Maybe ConstraintData + -- ^ additional data relevant to this 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 + +mapConstraintArgs :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a +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 + [ "contents" .= (bs, trunc) + ] + +constraintToJSON :: (a -> A.Value) -> Constraint a -> A.Value +constraintToJSON annToJSON Constraint {..} = + A.object + [ "constraintAnn" .= annToJSON constraintAnn + , "constraintClass" .= constraintClass + , "constraintKindArgs" .= fmap (typeToJSON annToJSON) constraintKindArgs + , "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 b -> + variant "TypeWildcard" a b + 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) + 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) + ConstrainedType a b c -> + variant "ConstrainedType" a (constraintToJSON annToJSON b, go c) + 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, 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" + constraintKindArgs <- o .:? "constraintKindArgs" .!= [] >>= traverse (typeFromJSON defaultAnn annFromJSON) + 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" -> do + b <- contents <|> pure Nothing + pure $ TypeWildcard a b + "TypeConstructor" -> + TypeConstructor a <$> contents + "TypeOp" -> + TypeOp a <$> contents + "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 + (b, c, d) <- contents + ForAll a 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 + "ConstrainedType" -> do + (b, c) <- contents + ConstrainedType a <$> constraintFromJSON defaultAnn annFromJSON b <*> go c + "Skolem" -> do + (b, c, d, e) <- contents + c' <- traverse go c + pure $ Skolem a b c' d e + "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 <*> 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 + go :: A.Value -> A.Parser (Type a) + go = typeFromJSON defaultAnn annFromJSON + +-- 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 + +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 + , 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 a -> ([RowListItem a], Type a) +rowToList = go where + 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 a -> ([RowListItem a], Type a) +rowToSortedList = first (sortOn rowListLabel) . rowToList + +-- | Convert a list of labels and types to a row +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 +isMonoType (ParensInType _ t) = isMonoType t +isMonoType (KindedType _ t _) = isMonoType t +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 + +-- | Replace a type variable, taking into account variable shadowing +replaceTypeVars :: Text -> Type a -> Type a -> Type a +replaceTypeVars v r = replaceAllTypeVars [(v, r)] + +-- | Replace named type variables with types +replaceAllTypeVars :: [(Text, Type a)] -> Type a -> Type a +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 (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 + where + mbK' = go bs m <$> mbK + keys = map fst m + usedVars = concatMap (usedTypeVariables . snd) m + 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) (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 + + 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 +usedTypeVariables :: Type a -> [Text] +usedTypeVariables = ordNub . everythingOnTypes (++) go where + go (TypeVar _ v) = [v] + go _ = [] + +-- | Collect all free type variables appearing in a type +freeTypeVariables :: Type a -> [Text] +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 +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 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, 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 + go :: Type a -> Bool + 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 + +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 + 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 (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) (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 + +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 + 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 <*> 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 (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) <*> (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 + +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 (constraintKindArgs c) ++ map go (constraintArgs c)) <+> go ty + 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 + go t@(ParensInType _ t1) = f t <+> go t1 + go other = f other + +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 (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) (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 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 + +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 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 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 +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 + +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 _ 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 (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 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' && 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 (TypeVar _ a) (TypeVar _ a') = compare a a' +compareType (TypeLevelString _ a) (TypeLevelString _ 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' +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 (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 +compareType (RCons _ a b c) (RCons _ a' b' c') = compare a a' <> compareType b b' <> compareType c c' +compareType (KindedType _ a b) (KindedType _ a' b') = compareType a a' <> compareType b b' +compareType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = compareType a a' <> compareType b b' <> compareType c c' +compareType (ParensInType _ a) (ParensInType _ a') = compareType a a' +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 +compareMaybeType Nothing Nothing = EQ +compareMaybeType Nothing _ = LT +compareMaybeType _ _ = 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 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 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/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/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/tests/TestCst.hs b/tests/TestCst.hs deleted file mode 100644 --- a/tests/TestCst.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# 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) - -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' :: String -> Text -> Gen SourceToken -readTok' failMsg t = case CST.lex t of - Right tok : _ -> - pure tok - Left (_, err) : _ -> - error $ failMsg <> ": " <> CST.prettyPrintError err - [] -> - error "Empty token stream" - -readTok :: Text -> Gen SourceToken -readTok = readTok' "Failed to parse" - -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 -> error $ "Failed to lex correctly: " <> show tok - -roundTripTok :: Text -> Gen Bool -roundTripTok t = do - tok <- readTok t - let t' = CST.printTokens [tok] - tok' <- readTok' "Failed to re-parse" 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 -> error "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 <- resize 0xFFFF arbitrarySizedNatural >>= (genStringChar '\'' . toEnum) - pure $ "'" <> ch <> "'" - -genString :: Gen PSSourceString -genString = PSSourceString <$> do - 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 - 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/purs/layout/AdoIn.out b/tests/purs/layout/AdoIn.out deleted file mode 100644 --- a/tests/purs/layout/AdoIn.out +++ /dev/null @@ -1,20 +0,0 @@ -module Test where{ - -test = ado{ - baz; - let {foo = bar}} - in bar; - -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} - diff --git a/tests/purs/layout/AdoIn.purs b/tests/purs/layout/AdoIn.purs deleted file mode 100644 --- a/tests/purs/layout/AdoIn.purs +++ /dev/null @@ -1,19 +0,0 @@ -module Test where - -test = ado - baz - let foo = bar - in bar - -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 diff --git a/tests/purs/layout/CaseGuards.out b/tests/purs/layout/CaseGuards.out deleted file mode 100644 --- a/tests/purs/layout/CaseGuards.out +++ /dev/null @@ -1,54 +0,0 @@ -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/CaseGuards.purs b/tests/purs/layout/CaseGuards.purs deleted file mode 100644 --- a/tests/purs/layout/CaseGuards.purs +++ /dev/null @@ -1,53 +0,0 @@ -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 deleted file mode 100644 --- a/tests/purs/layout/CaseWhere.out +++ /dev/null @@ -1,13 +0,0 @@ -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/CaseWhere.purs b/tests/purs/layout/CaseWhere.purs deleted file mode 100644 --- a/tests/purs/layout/CaseWhere.purs +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 --- a/tests/purs/layout/ClassHead.out +++ /dev/null @@ -1,11 +0,0 @@ -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/ClassHead.purs b/tests/purs/layout/ClassHead.purs deleted file mode 100644 --- a/tests/purs/layout/ClassHead.purs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/tests/purs/layout/Commas.out +++ /dev/null @@ -1,23 +0,0 @@ -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/Commas.purs b/tests/purs/layout/Commas.purs deleted file mode 100644 --- a/tests/purs/layout/Commas.purs +++ /dev/null @@ -1,22 +0,0 @@ -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 deleted file mode 100644 --- a/tests/purs/layout/Delimiter.out +++ /dev/null @@ -1,14 +0,0 @@ -module Test where{ - -test1 = a; -test2 = { - b -}; -test3 = do{ - foo; - bar ( - baz - ) == 12; - baz}; -test4 = c} - diff --git a/tests/purs/layout/Delimiter.purs b/tests/purs/layout/Delimiter.purs deleted file mode 100644 --- a/tests/purs/layout/Delimiter.purs +++ /dev/null @@ -1,13 +0,0 @@ -module Test where - -test1 = a -test2 = { - b -} -test3 = do - foo - bar ( - baz - ) == 12 - baz -test4 = c diff --git a/tests/purs/layout/DoLet.out b/tests/purs/layout/DoLet.out deleted file mode 100644 --- a/tests/purs/layout/DoLet.out +++ /dev/null @@ -1,16 +0,0 @@ -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}} - diff --git a/tests/purs/layout/DoLet.purs b/tests/purs/layout/DoLet.purs deleted file mode 100644 --- a/tests/purs/layout/DoLet.purs +++ /dev/null @@ -1,15 +0,0 @@ -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 diff --git a/tests/purs/layout/DoOperator.out b/tests/purs/layout/DoOperator.out deleted file mode 100644 --- a/tests/purs/layout/DoOperator.out +++ /dev/null @@ -1,9 +0,0 @@ -module Test where{ - -test = do{ - foo; - foo do{ - bar}} - <|> bar} - - diff --git a/tests/purs/layout/DoOperator.purs b/tests/purs/layout/DoOperator.purs deleted file mode 100644 --- a/tests/purs/layout/DoOperator.purs +++ /dev/null @@ -1,8 +0,0 @@ -module Test where - -test = do - foo - foo do - bar - <|> bar - diff --git a/tests/purs/layout/DoWhere.out b/tests/purs/layout/DoWhere.out deleted file mode 100644 --- a/tests/purs/layout/DoWhere.out +++ /dev/null @@ -1,7 +0,0 @@ -module Test where{ - -test = - do{ - do {do{ - foo }}}where {bar = baz}} - diff --git a/tests/purs/layout/DoWhere.purs b/tests/purs/layout/DoWhere.purs deleted file mode 100644 --- a/tests/purs/layout/DoWhere.purs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 --- a/tests/purs/layout/IfThenElseDo.out +++ /dev/null @@ -1,11 +0,0 @@ -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/IfThenElseDo.purs b/tests/purs/layout/IfThenElseDo.purs deleted file mode 100644 --- a/tests/purs/layout/IfThenElseDo.purs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/tests/purs/layout/InstanceChainElse.out +++ /dev/null @@ -1,5 +0,0 @@ -module Test where{ - -instance foo :: Foo Int else bar :: Foo String -else baz :: Foo Boolean} - diff --git a/tests/purs/layout/InstanceChainElse.purs b/tests/purs/layout/InstanceChainElse.purs deleted file mode 100644 --- a/tests/purs/layout/InstanceChainElse.purs +++ /dev/null @@ -1,4 +0,0 @@ -module Test where - -instance foo :: Foo Int else bar :: Foo String -else baz :: Foo Boolean diff --git a/tests/purs/layout/LetGuards.out b/tests/purs/layout/LetGuards.out deleted file mode 100644 --- a/tests/purs/layout/LetGuards.out +++ /dev/null @@ -1,30 +0,0 @@ -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}} - diff --git a/tests/purs/layout/LetGuards.purs b/tests/purs/layout/LetGuards.purs deleted file mode 100644 --- a/tests/purs/layout/LetGuards.purs +++ /dev/null @@ -1,29 +0,0 @@ -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