packages feed

purescript-cst 0.3.0.0 → 0.4.0.0

raw patch · 14 files changed

+11/−167 lines, 14 files

Files

README.md view
@@ -10,6 +10,7 @@ | --- | --- | | 0.14.2 | 0.2.0.0 | | 0.14.3 | 0.3.0.0 |+| 0.14.4 | 0.4.0.0 |  Before v0.14.2, there was a third package, `purescript-ast`. In v0.14.2, `purescript-ast` was merged into `purescript-cst`.
purescript-cst.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               purescript-cst-version:            0.3.0.0+version:            0.4.0.0 license:            BSD-3-Clause license-file:       LICENSE copyright:
src/Control/Monad/Supply.hs view
@@ -11,8 +11,6 @@ import Control.Monad.State import Control.Monad.Writer -import Data.Functor.Identity- newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }   deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) @@ -21,11 +19,3 @@  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/Language/PureScript/AST/Declarations.hs view
@@ -84,6 +84,7 @@   | ErrorInKindDeclaration (ProperName 'TypeName)   | ErrorInRoleDeclaration (ProperName 'TypeName)   | ErrorInForeignImport Ident+  | ErrorInForeignImportData (ProperName 'TypeName)   | ErrorSolvingConstraint SourceConstraint   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))   | PositionedError (NEL.NonEmpty SourceSpan)@@ -291,10 +292,6 @@   | Hiding [DeclarationRef]   deriving (Eq, Show, Generic, Serialise) -isImplicit :: ImportDeclarationType -> Bool-isImplicit Implicit = True-isImplicit _ = False- isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True isExplicit _ = False@@ -323,9 +320,6 @@   , tydeclType :: !SourceType   } deriving (Show, Eq) -overTypeDeclaration :: (TypeDeclarationData -> TypeDeclarationData) -> Declaration -> Declaration-overTypeDeclaration f d = maybe d (TypeDeclaration . f) (getTypeDeclaration d)- getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d getTypeDeclaration _ = Nothing@@ -348,9 +342,6 @@   , 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@@ -719,11 +710,6 @@   --   | 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@@ -733,10 +719,6 @@   | 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   --
src/Language/PureScript/AST/Traversals.hs view
@@ -67,7 +67,6 @@   g' (UnaryMinus ss v) = g (UnaryMinus ss (g' v))   g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))   g' (Parens v) = g (Parens (g' v))-  g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))   g' (Accessor prop v) = g (Accessor prop (g' v))   g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (fmap (fmap g') vs))   g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs))@@ -142,7 +141,6 @@   g' (UnaryMinus ss v) = UnaryMinus ss <$> (g v >>= g')   g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')   g' (Parens v) = Parens <$> (g v >>= g')-  g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')   g' (Accessor prop v) = Accessor prop <$> (g v >>= g')   g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs   g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs@@ -212,7 +210,6 @@   g' (UnaryMinus ss v) = (UnaryMinus ss <$> g' v) >>= g   g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g   g' (Parens v) = (Parens <$> g' v) >>= g-  g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g   g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g   g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g   g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g@@ -285,7 +282,6 @@   g' v@(UnaryMinus _ v1) = g v <>. g' v1   g' v@(BinaryNoParens op v1 v2) = g v <>. g' op <>. g' v1 <>. g' v2   g' v@(Parens v1) = g v <>. g' v1-  g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <>. g' v1   g' v@(Accessor _ v1) = g v <>. g' v1   g' v@(ObjectUpdate obj vs) = foldl (<>.) (g v <>. g' obj) (fmap (g' . snd) vs)   g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs)@@ -367,7 +363,6 @@   g' s (UnaryMinus _ v1) = g'' s v1   g' s (BinaryNoParens op v1 v2) = g'' s op <>. g'' s v1 <>. g'' s v2   g' s (Parens v1) = g'' s v1-  g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1   g' s (Accessor _ v1) = g'' s v1   g' s (ObjectUpdate obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s . snd) vs)   g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs)@@ -453,7 +448,6 @@   g' s (UnaryMinus ss v) = UnaryMinus ss <$> g'' s v   g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2   g' s (Parens v) = Parens <$> g'' s v-  g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v   g' s (Accessor prop v) = Accessor prop <$> g'' s v   g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs   g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs@@ -547,7 +541,6 @@   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
src/Language/PureScript/CST/Layout.hs view
@@ -265,7 +265,7 @@         ((_, LytTick) : stk', acc') ->           (stk', acc') & insertToken src         _ ->-          state & insertDefault & pushStack tokPos LytTick+          state & collapse offsideEndP & insertSep & insertToken src & pushStack tokPos LytTick      -- In general, commas should close all indented contexts.     --     example = [ do foo
src/Language/PureScript/CST/Monad.hs view
@@ -110,10 +110,6 @@ addFailure toks ty = Parser $ \st _ ksucc ->   ksucc (st { parserErrors = mkParserError [] toks ty : parserErrors st }) () -addFailures :: [ParserError] -> Parser ()-addFailures errs = Parser $ \st _ ksucc ->-  ksucc (st { parserErrors = errs <> parserErrors st }) ()- parseFail' :: [SourceToken] -> ParserErrorType -> Parser a parseFail' toks msg = Parser $ \st kerr _ -> kerr st (mkParserError [] toks msg)
src/Language/PureScript/CST/Positions.hs view
@@ -114,9 +114,6 @@ qualRange :: QualifiedName a -> TokenRange qualRange a = (qualTok a, qualTok a) -labelRange :: Label -> TokenRange-labelRange a = (lblTok a, lblTok a)- wrappedRange :: Wrapped a -> TokenRange wrappedRange Wrapped { wrpOpen, wrpClose } = (wrpOpen, wrpClose) @@ -338,8 +335,3 @@ recordUpdateRange = \case   RecordUpdateLeaf a _ b -> (lblTok a, snd $ exprRange b)   RecordUpdateBranch a (Wrapped _ _ b) -> (lblTok a, b)--recordLabeledExprRange :: RecordLabeled (Expr a) -> TokenRange-recordLabeledExprRange = \case-  RecordPun a -> nameRange a-  RecordField a _ b -> (fst $ labelRange a, snd $ exprRange b)
src/Language/PureScript/CST/Utils.hs view
@@ -85,18 +85,9 @@ unexpectedExpr :: Monoid a => [SourceToken] -> Expr a unexpectedExpr toks = ExprIdent mempty (unexpectedQual (head toks)) -unexpectedDecl :: Monoid a => [SourceToken] -> Declaration a-unexpectedDecl toks = DeclValue mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected"))- unexpectedBinder :: Monoid a => [SourceToken] -> Binder a unexpectedBinder toks = BinderVar mempty (unexpectedName (head toks)) -unexpectedLetBinding :: Monoid a => [SourceToken] -> LetBinding a-unexpectedLetBinding toks = LetBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected>"))--unexpectedInstBinding :: Monoid a => [SourceToken] -> InstanceBinding a-unexpectedInstBinding toks = InstanceBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected>"))- unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a unexpectedRecordUpdate toks = RecordUpdateLeaf (unexpectedLabel (head toks)) (head toks) (unexpectedExpr toks) @@ -119,9 +110,6 @@   go accum (x : xs) = go (x : accum) xs   go _ [] = internalError "Separated should not be empty" -consSeparated :: a -> SourceToken -> Separated a -> Separated a-consSeparated x sep Separated {..} = Separated x ((sep, sepHead) : sepTail)- internalError :: String -> a internalError = error . ("Internal parser error: " <>) @@ -169,9 +157,6 @@   TokRawString a    -> Label tok $ mkString a   TokForall ASCII   -> Label tok $ mkString "forall"   _                 -> internalError $ "Invalid label: " <> show tok--labelToIdent :: Label -> Parser (Name Ident)-labelToIdent (Label tok _) = toName Ident tok  toString :: SourceToken -> (SourceToken, PSString) toString tok = case tokValue tok of
src/Language/PureScript/Constants/Prim.hs view
@@ -13,9 +13,6 @@  -- Prim -partial :: forall a. (IsString a) => a-partial = "Partial"- pattern Prim :: ModuleName pattern Prim = ModuleName "Prim" @@ -45,12 +42,6 @@ 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@@ -134,9 +125,6 @@  typ :: forall a. (IsString a) => a typ = "Type"--kindBoolean :: forall a. (IsString a) => a-kindBoolean = "Boolean"  kindOrdering :: forall a. (IsString a) => a kindOrdering = "Ordering"
src/Language/PureScript/Environment.hs view
@@ -267,19 +267,12 @@ kindConstraint :: SourceType kindConstraint = primKind C.constraint -isKindType :: Type a -> Bool-isKindType (TypeConstructor _ n) = n == primName C.typ-isKindType _ = False- kindSymbol :: SourceType kindSymbol = primKind C.symbol  kindDoc :: SourceType kindDoc = primSubKind C.typeError C.doc -kindBoolean :: SourceType-kindBoolean = primSubKind C.moduleBoolean C.kindBoolean- kindOrdering :: SourceType kindOrdering = primSubKind C.moduleOrdering C.kindOrdering @@ -334,18 +327,6 @@ tyForall :: Text -> SourceType -> SourceType -> SourceType tyForall var k ty = ForAll nullSourceAnn var (Just k) ty Nothing --- | Check whether a type is a record-isObject :: Type a -> Bool-isObject = isTypeOrApplied tyRecord---- | Check whether a type is a function-isFunction :: Type a -> Bool-isFunction = isTypeOrApplied tyFunction--isTypeOrApplied :: Type a -> Type b -> Bool-isTypeOrApplied t1 (TypeApp _ t2 _) = eqType t1 t2-isTypeOrApplied t1 t2 = eqType t1 t2- -- | Smart constructor for function types function :: SourceType -> SourceType -> SourceType function = TypeApp nullSourceAnn . TypeApp nullSourceAnn tyFunction@@ -360,7 +341,7 @@   [ let k = mkKind kindConstraint     in (name, (k, ExternData (nominalRolesForKind k)))   , let k = mkKind kindType-    in (dictSynonymName <$> name, (k, TypeSynonym))+    in (dictTypeName <$> name, (k, TypeSynonym))   ]  -- | The primitive types in the external environment with their@@ -594,24 +575,18 @@ 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")+dictTypeName' :: Text -> Text+dictTypeName' = (<> "$Dict") -dictSynonymName :: ProperName a -> ProperName a-dictSynonymName = ProperName . dictSynonymName' . runProperName+dictTypeName :: ProperName a -> ProperName a+dictTypeName = ProperName . dictTypeName' . runProperName -isDictSynonym :: ProperName a -> Bool-isDictSynonym = T.isSuffixOf "$Dict" . runProperName+isDictTypeName :: ProperName a -> Bool+isDictTypeName = T.isSuffixOf "$Dict" . runProperName  -- | -- Given the kind of a type, generate a list @Nominal@ roles. This is used for
src/Language/PureScript/Names.hs view
@@ -57,10 +57,6 @@ getClassName (TyClassName name) = Just name getClassName _ = Nothing -getModName :: Name -> Maybe ModuleName-getModName (ModName name) = Just name-getModName _ = Nothing- -- | -- Names for value identifiers --
src/Language/PureScript/Traversals.hs view
@@ -3,9 +3,6 @@  import Prelude.Compat -fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b)-fstM f (a, b) = (, b) <$> f a- sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) sndM f (a, b) = (a, ) <$> f b @@ -14,10 +11,6 @@  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
src/Language/PureScript/Types.hs view
@@ -18,7 +18,6 @@ import qualified Data.IntSet as IS import Data.List (sort, sortOn) import Data.Maybe (fromMaybe, isJust)-import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic)@@ -105,9 +104,6 @@ srcTypeConstructor :: Qualified (ProperName 'TypeName) -> SourceType srcTypeConstructor = TypeConstructor NullSourceAnn -srcTypeOp :: Qualified (OpName 'TypeOpName) -> SourceType-srcTypeOp = TypeOp NullSourceAnn- srcTypeApp :: SourceType -> SourceType -> SourceType srcTypeApp = TypeApp NullSourceAnn @@ -129,12 +125,6 @@ srcKindedType :: SourceType -> SourceType -> SourceType srcKindedType = KindedType NullSourceAnn -srcBinaryNoParensType :: SourceType -> SourceType -> SourceType -> SourceType-srcBinaryNoParensType = BinaryNoParensType NullSourceAnn--srcParensInType :: SourceType -> SourceType-srcParensInType = ParensInType NullSourceAnn- pattern REmptyKinded :: forall a. a -> Maybe (Type a) -> Type a pattern REmptyKinded ann mbK <- (toREmptyKinded -> Just (ann, mbK)) @@ -185,12 +175,6 @@ overConstraintArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c) -mapConstraintKindArgs :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a-mapConstraintKindArgs f c = c { constraintKindArgs = f (constraintKindArgs c) }--overConstraintKindArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)-overConstraintKindArgs f c = (\args -> c { constraintKindArgs = args }) <$> f (constraintKindArgs c)- mapConstraintArgsAll :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a mapConstraintArgsAll f c =   c { constraintKindArgs = f (constraintKindArgs c)@@ -528,13 +512,6 @@   go qs cs (ConstrainedType ann c ty) = go qs ((ann, c) : cs) ty   go qs cs ty = foldl (\ty' (ann, q, sco, mbK) -> ForAll ann q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs --- | Check if a type contains wildcards-containsWildcards :: Type a -> Bool-containsWildcards = everythingOnTypes (||) go where-  go :: Type a -> Bool-  go TypeWildcard{} = True-  go _ = False- -- | Check if a type contains `forall` containsForAll :: Type a -> Bool containsForAll = everythingOnTypes (||) go where@@ -616,18 +593,6 @@   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@@ -639,18 +604,6 @@   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