Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
17 changes: 8 additions & 9 deletions src/Language/PureScript/AST/Binders.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,16 +26,16 @@ data Binder
-- |
-- A binder which binds an identifier
--
| VarBinder Ident
| VarBinder SourceSpan Ident
-- |
-- A binder which matches a data constructor
--
| ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]
| ConstructorBinder SourceSpan (Qualified (ProperName 'ConstructorName)) [Binder]
-- |
-- A operator alias binder. During the rebracketing phase of desugaring,
-- this data constructor will be removed.
--
| OpBinder (Qualified (OpName 'ValueOpName))
| OpBinder SourceSpan (Qualified (OpName 'ValueOpName))
-- |
-- Binary operator application. During the rebracketing phase of desugaring,
-- this data constructor will be removed.
Expand All @@ -52,7 +52,7 @@ data Binder
-- |
-- A binder which binds its input to an identifier
--
| NamedBinder Ident Binder
| NamedBinder SourceSpan Ident Binder
-- |
-- A binder with source position information
--
Expand All @@ -70,11 +70,11 @@ binderNames :: Binder -> [Ident]
binderNames = go []
where
go ns (LiteralBinder b) = lit ns b
go ns (VarBinder name) = name : ns
go ns (ConstructorBinder _ bs) = foldl go ns bs
go ns (VarBinder _ name) = name : ns
go ns (ConstructorBinder _ _ bs) = foldl go ns bs
go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]
go ns (ParensInBinder b) = go ns b
go ns (NamedBinder name b) = go (name : ns) b
go ns (NamedBinder _ name b) = go (name : ns) b
go ns (PositionedBinder _ _ b) = go ns b
go ns (TypedBinder _ b) = go ns b
go ns _ = ns
Expand All @@ -84,8 +84,7 @@ binderNames = go []

isIrrefutable :: Binder -> Bool
isIrrefutable NullBinder = True
isIrrefutable (VarBinder _) = True
isIrrefutable (VarBinder _ _) = True
isIrrefutable (PositionedBinder _ _ b) = isIrrefutable b
isIrrefutable (TypedBinder _ b) = isIrrefutable b
isIrrefutable _ = False

12 changes: 6 additions & 6 deletions src/Language/PureScript/AST/Declarations.hs
Original file line number Diff line number Diff line change
Expand Up @@ -697,7 +697,7 @@ data Expr
-- |
-- A prefix -, will be desugared
--
| UnaryMinus Expr
| UnaryMinus SourceSpan Expr
-- |
-- Binary operator application. During the rebracketing phase of desugaring, this data constructor
-- will be removed.
Expand Down Expand Up @@ -737,20 +737,20 @@ data Expr
-- |
-- Variable
--
| Var (Qualified Ident)
| Var SourceSpan (Qualified Ident)
-- |
-- An operator. This will be desugared into a function during the "operators"
-- phase of desugaring.
--
| Op (Qualified (OpName 'ValueOpName))
| Op SourceSpan (Qualified (OpName 'ValueOpName))
-- |
-- Conditional (if-then-else expression)
--
| IfThenElse Expr Expr Expr
-- |
-- A data constructor
--
| Constructor (Qualified (ProperName 'ConstructorName))
| Constructor SourceSpan (Qualified (ProperName 'ConstructorName))
-- |
-- A case expression. During the case expansion phase of desugaring, top-level binders will get
-- desugared into case expressions, hence the need for guards and multiple binders per branch here.
Expand Down Expand Up @@ -883,8 +883,8 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDe

isTrueExpr :: Expr -> Bool
isTrueExpr (Literal (BooleanLiteral True)) = True
isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
isTrueExpr (TypedValue _ e _) = isTrueExpr e
isTrueExpr (PositionedValue _ _ e) = isTrueExpr e
isTrueExpr _ = False
3 changes: 3 additions & 0 deletions src/Language/PureScript/AST/SourcePos.hs
Original file line number Diff line number Diff line change
Expand Up @@ -80,3 +80,6 @@ instance A.FromJSON SourceSpan where

internalModuleSourceSpan :: String -> SourceSpan
internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)

nullSourceSpan :: SourceSpan
nullSourceSpan = internalModuleSourceSpan ""
42 changes: 21 additions & 21 deletions src/Language/PureScript/AST/Traversals.hs
Original file line number Diff line number Diff line change
Expand Up @@ -63,7 +63,7 @@ everywhereOnValues f g h = (f', g', h')

g' :: Expr -> Expr
g' (Literal l) = g (Literal (lit g' l))
g' (UnaryMinus v) = g (UnaryMinus (g' v))
g' (UnaryMinus ss v) = g (UnaryMinus ss (g' v))
g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
g' (Parens v) = g (Parens (g' v))
g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
Expand All @@ -82,11 +82,11 @@ everywhereOnValues f g h = (f', g', h')
g' other = g other

h' :: Binder -> Binder
h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (fmap h' bs))
h' (ConstructorBinder ss ctor bs) = h (ConstructorBinder ss ctor (fmap h' bs))
h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
h' (ParensInBinder b) = h (ParensInBinder (h' b))
h' (LiteralBinder l) = h (LiteralBinder (lit h' l))
h' (NamedBinder name b) = h (NamedBinder name (h' b))
h' (NamedBinder ss name b) = h (NamedBinder ss name (h' b))
h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
h' (TypedBinder t b) = h (TypedBinder t (h' b))
h' other = h other
Expand Down Expand Up @@ -137,7 +137,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

g' :: Expr -> m Expr
g' (Literal l) = Literal <$> litM (g >=> g') l
g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
g' (UnaryMinus ss v) = UnaryMinus ss <$> (g v >>= g')
g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
g' (Parens v) = Parens <$> (g v >>= g')
g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
Expand All @@ -157,10 +157,10 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

h' :: Binder -> m Binder
h' (LiteralBinder l) = LiteralBinder <$> litM (h >=> h') l
h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs
h' (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h' <=< h) bs
h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
h' (NamedBinder ss name b) = NamedBinder ss name <$> (h b >>= h')
h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')
h' other = h other
Expand Down Expand Up @@ -206,7 +206,7 @@ everywhereOnValuesM f g h = (f', g', h')

g' :: Expr -> m Expr
g' (Literal l) = (Literal <$> litM g' l) >>= g
g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
g' (UnaryMinus ss v) = (UnaryMinus ss <$> g' v) >>= g
g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
g' (Parens v) = (Parens <$> g' v) >>= g
g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
Expand All @@ -226,10 +226,10 @@ everywhereOnValuesM f g h = (f', g', h')

h' :: Binder -> m Binder
h' (LiteralBinder l) = (LiteralBinder <$> litM h' l) >>= h
h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h
h' (ConstructorBinder ss ctor bs) = (ConstructorBinder ss ctor <$> traverse h' bs) >>= h
h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
h' (NamedBinder ss name b) = (NamedBinder ss name <$> h' b) >>= h
h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h
h' other = h other
Expand Down Expand Up @@ -278,7 +278,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

g' :: Expr -> r
g' v@(Literal l) = lit (g v) g' l
g' v@(UnaryMinus v1) = g v <> g' v1
g' v@(UnaryMinus _ v1) = g v <> g' v1
g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2
g' v@(Parens v1) = g v <> g' v1
g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
Expand All @@ -298,10 +298,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

h' :: Binder -> r
h' b@(LiteralBinder l) = lit (h b) h' l
h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (fmap h' bs)
h' b@(ConstructorBinder _ _ bs) = foldl (<>) (h b) (fmap h' bs)
h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3
h' b@(ParensInBinder b1) = h b <> h' b1
h' b@(NamedBinder _ b1) = h b <> h' b1
h' b@(NamedBinder _ _ b1) = h b <> h' b1
h' b@(PositionedBinder _ _ b1) = h b <> h' b1
h' b@(TypedBinder _ b1) = h b <> h' b1
h' b = h b
Expand Down Expand Up @@ -359,7 +359,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

g' :: s -> Expr -> r
g' s (Literal l) = lit g'' s l
g' s (UnaryMinus v1) = g'' s v1
g' s (UnaryMinus _ v1) = g'' s v1
g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
g' s (Parens v1) = g'' s v1
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
Expand All @@ -382,10 +382,10 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

h' :: s -> Binder -> r
h' s (LiteralBinder l) = lit h'' s l
h' s (ConstructorBinder _ bs) = foldl (<>) r0 (fmap (h'' s) bs)
h' s (ConstructorBinder _ _ bs) = foldl (<>) r0 (fmap (h'' s) bs)
h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3
h' s (ParensInBinder b) = h'' s b
h' s (NamedBinder _ b1) = h'' s b1
h' s (NamedBinder _ _ b1) = h'' s b1
h' s (PositionedBinder _ _ b1) = h'' s b1
h' s (TypedBinder _ b1) = h'' s b1
h' _ _ = r0
Expand Down Expand Up @@ -444,7 +444,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g'' s = uncurry g' <=< g s

g' s (Literal l) = Literal <$> lit g'' s l
g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
g' s (UnaryMinus ss v) = UnaryMinus ss <$> g'' s v
g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
g' s (Parens v) = Parens <$> g'' s v
g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
Expand All @@ -465,10 +465,10 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
h'' s = uncurry h' <=< h s

h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l
h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs
h' s (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h'' s) bs
h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
h' s (NamedBinder ss name b) = NamedBinder ss name <$> h'' s b
h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
h' s (TypedBinder t b) = TypedBinder t <$> h'' s b
h' _ other = return other
Expand Down Expand Up @@ -534,7 +534,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

g' :: S.Set Ident -> Expr -> r
g' s (Literal l) = lit g'' s l
g' s (UnaryMinus v1) = g'' s v1
g' s (UnaryMinus _ v1) = g'' s v1
g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
g' s (Parens v1) = g'' s v1
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
Expand Down Expand Up @@ -563,10 +563,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

h' :: S.Set Ident -> Binder -> r
h' s (LiteralBinder l) = lit h'' s l
h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
h' s (ParensInBinder b) = h'' s b
h' s (NamedBinder name b1) = h'' (S.insert name s) b1
h' s (NamedBinder _ name b1) = h'' (S.insert name s) b1
h' s (PositionedBinder _ _ b1) = h'' s b1
h' s (TypedBinder _ b1) = h'' s b1
h' _ _ = mempty
Expand Down
18 changes: 9 additions & 9 deletions src/Language/PureScript/CoreFn/Desugar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -79,21 +79,21 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ fmap (second (exprToCoreFn ss [] Nothing)) vs
exprToCoreFn ss com ty (A.Abs (A.VarBinder name) v) =
exprToCoreFn ss com ty (A.Abs (A.VarBinder _ name) v) =
Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
exprToCoreFn _ _ _ (A.Abs _ _) =
internalError "Abs with Binder argument was not desugared before exprToCoreFn mn"
exprToCoreFn ss com ty (A.App v1 v2) =
App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)
exprToCoreFn ss com ty (A.Var ident) =
exprToCoreFn _ com ty (A.Var ss ident) =
Var (ss, com, ty, getValueMeta ident) ident
exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =
Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
[ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True]
(Right $ exprToCoreFn ss [] Nothing v2)
, CaseAlternative [NullBinder (ssAnn ss)]
(Right $ exprToCoreFn ss [] Nothing v3) ]
exprToCoreFn ss com ty (A.Constructor name) =
exprToCoreFn _ com ty (A.Constructor ss name) =
Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name
exprToCoreFn ss com ty (A.Case vs alts) =
Case (ss, com, ty, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts)
Expand Down Expand Up @@ -137,12 +137,12 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)
binderToCoreFn ss com A.NullBinder =
NullBinder (ss, com, Nothing, Nothing)
binderToCoreFn ss com (A.VarBinder name) =
binderToCoreFn _ com (A.VarBinder ss name) =
VarBinder (ss, com, Nothing, Nothing) name
binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) =
let (_, tctor, _, _) = lookupConstructor env dctor
in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs)
binderToCoreFn ss com (A.NamedBinder name b) =
binderToCoreFn _ com (A.NamedBinder ss name b) =
NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
binderToCoreFn ss (com ++ com1) b
Expand Down Expand Up @@ -198,16 +198,16 @@ findQualModules decls =
fqDecls _ = []

fqValues :: A.Expr -> [ModuleName]
fqValues (A.Var q) = getQual' q
fqValues (A.Constructor q) = getQual' q
fqValues (A.Var _ q) = getQual' q
fqValues (A.Constructor _ q) = getQual' q
-- Some instances are automatically solved and have their class dictionaries
-- built inline instead of having a named instance defined and imported.
-- We therefore need to import these constructors if they aren't already.
fqValues (A.TypeClassDictionaryConstructorApp c _) = getQual' c
fqValues _ = []

fqBinders :: A.Binder -> [ModuleName]
fqBinders (A.ConstructorBinder q _) = getQual' q
fqBinders (A.ConstructorBinder _ q _) = getQual' q
fqBinders _ = []

getQual' :: Qualified a -> [ModuleName]
Expand Down
4 changes: 2 additions & 2 deletions src/Language/PureScript/Interactive/Module.hs
Original file line number Diff line number Diff line change
Expand Up @@ -49,8 +49,8 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
effModuleName = P.moduleNameFromString "Control.Monad.Eff"
effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"]))
supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"]))
eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval"))
mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it")))
eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval"))
mainValue = P.App eval (P.Var internalSpan (P.Qualified Nothing (P.Ident "it")))
itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val]
typeDecl = P.TypeDeclaration
(P.TypeDeclarationData (internalSpan, []) (P.Ident "$main")
Expand Down
10 changes: 5 additions & 5 deletions src/Language/PureScript/Linter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -54,24 +54,24 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec

stepE :: S.Set Ident -> Expr -> MultipleErrors
stepE s (Abs (VarBinder name) _) | name `S.member` s = errorMessage (ShadowedName name)
stepE s (Abs (VarBinder ss name) _) | name `S.member` s = errorMessage' ss (ShadowedName name)
stepE s (Let ds' _) = foldMap go ds'
where
go d | Just i <- getDeclIdent d
, i `S.member` s = errorMessage (ShadowedName i)
, i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i)
| otherwise = mempty
stepE _ _ = mempty

stepB :: S.Set Ident -> Binder -> MultipleErrors
stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)
stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)
stepB s (VarBinder ss name) | name `S.member` s = errorMessage' ss (ShadowedName name)
stepB s (NamedBinder ss name _) | name `S.member` s = errorMessage' ss (ShadowedName name)
stepB _ _ = mempty

stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors
stepDo s (DoNotationLet ds') = foldMap go ds'
where
go d | Just i <- getDeclIdent d
, i `S.member` s = errorMessage (ShadowedName i)
, i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i)
| otherwise = mempty
stepDo _ _ = mempty

Expand Down
Loading