packages feed

purescript-cst 0.1.1.0 → 0.2.0.0

raw patch · 59 files changed

+4590/−780 lines, 59 filesdep +aesondep +deepseqdep +microlensdep −purescript-astdep −purescript-cstdep −tasty

Dependencies added: aeson, deepseq, microlens, mtl, protolude, serialise, vector

Dependencies removed: purescript-ast, purescript-cst, tasty, tasty-golden, tasty-quickcheck

Files

README.md view
@@ -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 |
purescript-cst.cabal view
@@ -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
+ src/Control/Monad/Supply.hs view
@@ -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
+ src/Control/Monad/Supply/Class.hs view
@@ -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
+ src/Language/PureScript/AST.hs view
@@ -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
+ src/Language/PureScript/AST/Binders.hs view
@@ -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
+ src/Language/PureScript/AST/Declarations.hs view
@@ -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
+ src/Language/PureScript/AST/Declarations/ChainId.hs view
@@ -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)
+ src/Language/PureScript/AST/Exported.hs view
@@ -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
+ src/Language/PureScript/AST/Literals.hs view
@@ -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)
+ src/Language/PureScript/AST/Operators.hs view
@@ -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+             ]
+ src/Language/PureScript/AST/SourcePos.hs view
@@ -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, [])
+ src/Language/PureScript/AST/Traversals.hs view
@@ -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
src/Language/PureScript/CST/Convert.hs view
@@ -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'
src/Language/PureScript/CST/Errors.hs view
@@ -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 ->
src/Language/PureScript/CST/Flatten.hs view
@@ -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
src/Language/PureScript/CST/Lexer.hs view
@@ -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'
src/Language/PureScript/CST/Monad.hs view
@@ -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
src/Language/PureScript/CST/Parser.y view
@@ -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 }
src/Language/PureScript/CST/Positions.hs view
@@ -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)
src/Language/PureScript/CST/Types.hs view
@@ -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]
src/Language/PureScript/CST/Utils.hs view
@@ -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
+ src/Language/PureScript/Comments.hs view
@@ -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)
+ src/Language/PureScript/Constants/Prim.hs view
@@ -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"
+ src/Language/PureScript/Crash.hs view
@@ -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")
+ src/Language/PureScript/Environment.hs view
@@ -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)
+ src/Language/PureScript/Label.hs view
@@ -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
+ src/Language/PureScript/Names.hs view
@@ -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
+ src/Language/PureScript/PSString.hs view
@@ -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
+ src/Language/PureScript/Roles.hs view
@@ -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"
+ src/Language/PureScript/Traversals.hs view
@@ -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)
+ src/Language/PureScript/TypeClassDictionaries.hs view
@@ -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)
+ src/Language/PureScript/Types.hs view
@@ -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'
− tests/Main.hs 
@@ -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-      ]
− tests/TestCst.hs 
@@ -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']
− tests/purs/layout/AdoIn.out 
@@ -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}-<eof>
− tests/purs/layout/AdoIn.purs 
@@ -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
− tests/purs/layout/CaseGuards.out 
@@ -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}--<eof>
− tests/purs/layout/CaseGuards.purs 
@@ -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-
− tests/purs/layout/CaseWhere.out 
@@ -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}}}-<eof>
− tests/purs/layout/CaseWhere.purs 
@@ -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
− tests/purs/layout/ClassHead.out 
@@ -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}-<eof>
− tests/purs/layout/ClassHead.purs 
@@ -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
− tests/purs/layout/Commas.out 
@@ -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}}}--<eof>
− tests/purs/layout/Commas.purs 
@@ -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-
− tests/purs/layout/Delimiter.out 
@@ -1,14 +0,0 @@-module Test where{--test1 = a;-test2 = {-  b-};-test3 = do{-  foo;-  bar (-    baz-  ) == 12;-  baz};-test4 = c}-<eof>
− tests/purs/layout/Delimiter.purs 
@@ -1,13 +0,0 @@-module Test where--test1 = a-test2 = {-  b-}-test3 = do-  foo-  bar (-    baz-  ) == 12-  baz-test4 = c
− tests/purs/layout/DoLet.out 
@@ -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}}-<eof>
− tests/purs/layout/DoLet.purs 
@@ -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
− tests/purs/layout/DoOperator.out 
@@ -1,9 +0,0 @@-module Test where{--test = do{-  foo;-  foo do{-    bar}}-  <|> bar}--<eof>
− tests/purs/layout/DoOperator.purs 
@@ -1,8 +0,0 @@-module Test where--test = do-  foo-  foo do-    bar-  <|> bar-
− tests/purs/layout/DoWhere.out 
@@ -1,7 +0,0 @@-module Test where{--test =-  do{-    do {do{-        foo }}}where {bar = baz}}-<eof>
− tests/purs/layout/DoWhere.purs 
@@ -1,6 +0,0 @@-module Test where--test =-  do-    do do-        foo where bar = baz
− tests/purs/layout/IfThenElseDo.out 
@@ -1,11 +0,0 @@-module Test where{--foo = do{-  if true then-    false-  else if false then do{-    that}-    else do{-     what};-  that}}-<eof>
− tests/purs/layout/IfThenElseDo.purs 
@@ -1,10 +0,0 @@-module Test where--foo = do-  if true then-    false-  else if false then do-    that-    else do-     what-  that
− tests/purs/layout/InstanceChainElse.out 
@@ -1,5 +0,0 @@-module Test where{--instance foo :: Foo Int else bar :: Foo String-else baz :: Foo Boolean}-<eof>
− tests/purs/layout/InstanceChainElse.purs 
@@ -1,4 +0,0 @@-module Test where--instance foo :: Foo Int else bar :: Foo String-else baz :: Foo Boolean
− tests/purs/layout/LetGuards.out 
@@ -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}}-<eof>
− tests/purs/layout/LetGuards.purs 
@@ -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