packages feed

purescript-ast (empty) → 0.1.0.0

raw patch · 25 files changed

+4513/−0 lines, 25 filesdep +aesondep +basedep +base-compatsetup-changed

Dependencies added: aeson, base, base-compat, bytestring, containers, deepseq, filepath, microlens, mtl, protolude, scientific, serialise, text, vector

Files

+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other+contributors+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# purescript-ast++Defines the underlying syntax of the PureScript Programming Language.++## Compiler compatibility++We provide a table to make it a bit easier to map between versions of `purescript` and `purescript-ast`.++| `purescript` | `purescript-ast` |+| --- | --- |+| `0.13.6` | `0.1.0.0` |
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ purescript-ast.cabal view
@@ -0,0 +1,80 @@+cabal-version:      1.12+name:               purescript-ast+version:            0.1.0.0+license:            BSD3+license-file:       LICENSE+copyright:+    (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md)++maintainer:+    Gary Burgess <gary.burgess@gmail.com>, Hardy Jones <jones3.hardy@gmail.com>, Harry Garrood <harry@garrood.me>, Christoph Hegemann <christoph.hegemann1337@gmail.com>, Liam Goodacre <goodacre.liam@gmail.com>, Nathan Faubion <nathan@n-son.com>++author:             Phil Freeman <paf31@cantab.net>+stability:          experimental+homepage:           http://www.purescript.org/+bug-reports:        https://github.com/purescript/purescript/issues+synopsis:           PureScript Programming Language Abstract Syntax Tree+description:+    Defines the underlying syntax of the PureScript Programming Language.++category:           Language+build-type:         Simple+extra-source-files: README.md++source-repository head+    type:     git+    location: https://github.com/purescript/purescript++library+    exposed-modules:+        Control.Monad.Supply+        Control.Monad.Supply.Class+        Language.PureScript.AST+        Language.PureScript.AST.Binders+        Language.PureScript.AST.Declarations+        Language.PureScript.AST.Exported+        Language.PureScript.AST.Literals+        Language.PureScript.AST.Operators+        Language.PureScript.AST.SourcePos+        Language.PureScript.AST.Traversals+        Language.PureScript.Comments+        Language.PureScript.Constants.Prim+        Language.PureScript.Crash+        Language.PureScript.Environment+        Language.PureScript.Label+        Language.PureScript.Names+        Language.PureScript.PSString+        Language.PureScript.Roles+        Language.PureScript.Traversals+        Language.PureScript.TypeClassDictionaries+        Language.PureScript.Types++    hs-source-dirs:     src+    other-modules:      Paths_purescript_ast+    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 -O2+    build-depends:+        aeson >=1.0 && <1.5,+        base >=4.11 && <4.13,+        base-compat >=0.6.0 && <0.11,+        bytestring <0.11,+        containers <0.7,+        deepseq <1.5,+        filepath <1.5,+        microlens >=0.4.10 && <0.5,+        mtl >=2.1.0 && <2.3.0,+        protolude >=0.1.6 && <0.2.4,+        scientific >=0.3.4.9 && <0.4,+        serialise <0.3,+        text <1.3,+        vector <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,155 @@+-- |+-- 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 = go []+  where+  go ns (LiteralBinder _ b) = lit ns b+  go ns (VarBinder _ name) = name : ns+  go ns (ConstructorBinder _ _ bs) = foldl go ns bs+  go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]+  go ns (ParensInBinder b) = go ns b+  go ns (NamedBinder _ name b) = go (name : ns) b+  go ns (PositionedBinder _ _ b) = go ns b+  go ns (TypedBinder _ b) = go ns b+  go ns _ = ns+  lit ns (ObjectLiteral bs) = foldl go ns (map snd bs)+  lit ns (ArrayLiteral bs) = foldl go ns bs+  lit ns _ = ns++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,841 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Data types for modules and declarations+--+module Language.PureScript.AST.Declarations where++import Prelude.Compat++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.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 [Ident] Integer 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 _ _ _ _) = Just (IdentName 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/Exported.hs view
@@ -0,0 +1,156 @@+module Language.PureScript.AST.Exported+  ( exportedDeclarations+  , isExported+  ) where++import Prelude.Compat+import Protolude (sortBy, on)++import Control.Category ((>>>))++import Data.Maybe (mapMaybe)+import qualified Data.Map as M++import Language.PureScript.AST.Declarations+import Language.PureScript.Types+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 =+  sortBy (compare `on` 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/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,26 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImplicitParams #-}++module Language.PureScript.Crash where++import Prelude.Compat++import qualified GHC.Stack++-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.+#if __GLASGOW_HASKELL__ >= 800+type HasCallStack = GHC.Stack.HasCallStack+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)+type HasCallStack = (?callStack :: GHC.Stack.CallStack)+#else+import GHC.Exts (Constraint)+-- CallStack wasn't present in GHC 7.10.1+type HasCallStack = (() :: Constraint)+#endif++-- | Exit with an error message and a crash report link.+internalError :: HasCallStack => String -> a+internalError =+  error+  . ("An internal error occurred during compilation: " ++)+  . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")
+ src/Language/PureScript/Environment.hs view
@@ -0,0 +1,631 @@+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 tcIsEmpty = TypeClassData args m s deps determinedArgs coveringSets tcIsEmpty+  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 (\r -> not (r `elem` 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" $ \str ->+    case str of+      "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 t1 t2 = TypeApp nullSourceAnn (TypeApp nullSourceAnn tyFunction t1) t2++-- 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" || T.isPrefixOf "Prim." 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,238 @@+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.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) = flip (,) b <$> f a++sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)+sndM f (a, b) = (,) a <$> f b++thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d)+thirdM f (a, b, c) = (,,) a b <$> f c++pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)+pairM f g (a, b)  = (,) <$> f a <*> g b++maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b)+maybeM _ Nothing = pure Nothing+maybeM f (Just a) = Just <$> f a++eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)+eitherM f _ (Left a)  = Left  <$> f a+eitherM _ g (Right b) = Right <$> g b++defS :: (Monad m) => st -> val -> m (st, val)+defS s val = return (s, val)
+ src/Language/PureScript/TypeClassDictionaries.hs view
@@ -0,0 +1,45 @@+module Language.PureScript.TypeClassDictionaries where++import Prelude.Compat++import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import Data.Text (Text, pack)++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 :: [Qualified Ident]+    -- | 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,783 @@+-- |+-- 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, sortBy)+import Data.Ord (comparing)+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)++import Language.PureScript.AST.SourcePos+import qualified Language.PureScript.Constants.Prim as C+import Language.PureScript.Names+import Language.PureScript.Label (Label)+import Language.PureScript.PSString (PSString)++import Lens.Micro (Lens', (^.), set)++type SourceType = Type SourceAnn+type SourceConstraint = Constraint SourceAnn++-- |+-- 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 (sortBy (comparing 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++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'