Skip to content

Commit ad4db86

Browse files
UnisayUnisay
committed
inline annotation support; Golden tests reorganized.
1 parent 6b3131b commit ad4db86

130 files changed

Lines changed: 810 additions & 623 deletions

File tree

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

‎lib/Language/PureScript/Backend/IR.hs‎

Lines changed: 73 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
module Language.PureScript.Backend.IR
22
( module Language.PureScript.Backend.IR
33
, module Language.PureScript.Backend.IR.Types
4+
, module Language.PureScript.Backend.IR.Names
45
) where
56

67
import Control.Monad.Error.Class (MonadError (throwError))
@@ -14,11 +15,11 @@ import Data.Text qualified as Text
1415
import Data.Traversable (for)
1516
import Language.PureScript.Backend.IR.Inliner (Annotation)
1617
import Language.PureScript.Backend.IR.Inliner qualified as Inliner
18+
import Language.PureScript.Backend.IR.Names
1719
import Language.PureScript.Backend.IR.Types
1820
import Language.PureScript.Comments (Comment (..))
1921
import Language.PureScript.CoreFn qualified as Cfn
2022
import Language.PureScript.CoreFn.Laziness (applyLazinessTransform)
21-
import Language.PureScript.Names (ModuleName (..), runModuleName)
2223
import Language.PureScript.Names qualified as Names
2324
import Language.PureScript.Names qualified as PS
2425
import Language.PureScript.PSString
@@ -35,7 +36,7 @@ import Prelude hiding (identity, show)
3536

3637
data Context = Context
3738
{ annotations
38-
∷ [Annotation]
39+
∷ Map Name Annotation
3940
, contextModule
4041
∷ Cfn.Module Cfn.Ann
4142
, contextDataTypes
@@ -87,7 +88,7 @@ mkModule cfnModule contextDataTypes = do
8788
, needsRuntimeLazy = Any False
8889
}
8990
do
90-
moduleBindings ← mkDecls
91+
moduleBindings ← mkBindings
9192
moduleImports ← mkImports
9293
moduleExports ← mkExports
9394
moduleReExports ← mkReExports
@@ -103,20 +104,20 @@ mkModule cfnModule contextDataTypes = do
103104
, moduleForeigns
104105
}
105106

106-
parseAnnotations ∷ Cfn.Module Cfn.Ann → Either CoreFnError [Annotation]
107+
parseAnnotations ∷ Cfn.Module Cfn.Ann → Either CoreFnError (Map Name Annotation)
107108
parseAnnotations currentModule =
108109
Cfn.moduleComments currentModule
109110
& foldMapM \case
110-
LineComment line → pure <$> parseAnnotationLine line
111-
BlockComment block → traverse parseAnnotationLine (lines block)
112-
& fmap catMaybes
111+
LineComment line → pure <$> parsePragmaLine line
112+
BlockComment block → traverse parsePragmaLine (lines block)
113+
& fmap (Map.fromList . catMaybes)
113114
where
114-
parseAnnotationLine ∷ Text → Either CoreFnError (Maybe Annotation)
115-
parseAnnotationLine (Text.strip → ln) = do
116-
let parser = optional (Inliner.annotationParser <* Megaparsec.eof)
117-
first
118-
(CoreFnError (Cfn.moduleName currentModule) . AnnotationParsingError)
119-
(Megaparsec.parse parser (Cfn.modulePath currentModule) ln)
115+
parsePragmaLine ∷ Text → Either CoreFnError (Maybe Inliner.Pragma)
116+
parsePragmaLine ln = do
117+
let parser = optional (Inliner.pragmaParser <* Megaparsec.eof)
118+
Megaparsec.parse parser (Cfn.modulePath currentModule) (Text.strip ln)
119+
& first
120+
(CoreFnError (Cfn.moduleName currentModule) . AnnotationParsingError)
120121

121122
mkImports ∷ RepM [ModuleName]
122123
mkImports = do
@@ -169,80 +170,88 @@ mkQualified f (PS.Qualified by a) =
169170
identToName ∷ PS.Ident → Name
170171
identToName = Name . PS.runIdent
171172

172-
mkDecls ∷ RepM [Grouping (Ann, Name, Exp)]
173-
mkDecls = do
174-
psDecls ← gets $ contextModule >>> Cfn.moduleBindings
175-
traverse mkGrouping psDecls
176-
177-
mkGrouping ∷ Cfn.Bind Cfn.Ann → RepM (Grouping (Ann, Name, Exp))
178-
mkGrouping = \case
179-
Cfn.NonRec _ann ident cfnExpr →
180-
Standalone . (noAnn,identToName ident,) <$> makeExp cfnExpr
173+
mkBindings ∷ RepM [Binding]
174+
mkBindings = do
175+
psBindings ← gets $ contextModule >>> Cfn.moduleBindings
176+
traverse mkBinding psBindings
177+
178+
mkBinding ∷ Cfn.Bind Cfn.Ann → RepM Binding
179+
mkBinding = \case
180+
Cfn.NonRec _ann ident cfnExpr → do
181+
let name = identToName ident
182+
ann ← gets $ annotations >>> Map.lookup name
183+
expr ← makeExprAnnotated ann cfnExpr
184+
pure $ Standalone (noAnn, name, expr)
181185
Cfn.Rec bindingGroup → do
182186
modname ← gets $ contextModule >>> Cfn.moduleName
183187
bindings ← writer $ applyLazinessTransform modname bindingGroup
184188
case NE.nonEmpty bindings of
185189
Nothing → throwContextualError EmptyBindingGroup
186190
Just bs →
187191
RecursiveGroup <$> for bs \((_ann, ident), expr) →
188-
(noAnn,identToName ident,) <$> makeExp expr
192+
(noAnn,identToName ident,) <$> makeExpr expr
193+
194+
makeExpr ∷ CfnExp → RepM Exp
195+
makeExpr = makeExprAnnotated Nothing
189196

190-
makeExp ∷ CfnExp → RepM Exp
191-
makeExp cfnExpr =
197+
makeExprAnnotated ∷ Ann → CfnExp → RepM Exp
198+
makeExprAnnotated ann cfnExpr =
192199
case cfnExpr of
193200
Cfn.Literal _ann literal →
194-
mkLiteral literal
195-
Cfn.Constructor ann tyName ctorName ids →
196-
mkConstructor ann tyName ctorName ids
201+
mkLiteral ann literal
202+
Cfn.Constructor cfnAnn tyName ctorName ids →
203+
mkConstructor cfnAnn ann tyName ctorName ids
197204
Cfn.Accessor _ann str expr →
198-
mkAccessor str expr
205+
mkAccessor ann str expr
199206
Cfn.ObjectUpdate _ann expr patches →
200207
mkObjectUpdate expr patches
201208
Cfn.Abs _ann ident expr →
202-
mkAbstraction ident expr
209+
mkAbstraction ann ident expr
203210
Cfn.App _ann abstr arg →
204211
mkApplication abstr arg
205212
Cfn.Var _ann qualifiedIdent →
206213
mkRef qualifiedIdent
207214
Cfn.Case _ann exprs alternatives →
208215
case NE.nonEmpty alternatives of
209-
Just as → mkCase exprs as
216+
Just as → mkCase ann exprs as
210217
Nothing → throwContextualError $ EmptyCase cfnExpr
211-
Cfn.Let _ann binds exprs → mkLet binds exprs
218+
Cfn.Let _ann binds exprs →
219+
mkLet ann binds exprs
212220

213-
mkLiteral ∷ Cfn.Literal CfnExp → RepM Exp
214-
mkLiteral = \case
221+
mkLiteral ∷ Ann → Cfn.Literal CfnExp → RepM Exp
222+
mkLiteral ann = \case
215223
Cfn.NumericLiteral (Left i) →
216-
pure $ literalInt i
224+
pure $ LiteralInt ann i
217225
Cfn.NumericLiteral (Right d) →
218-
pure $ literalFloat d
226+
pure $ LiteralFloat ann d
219227
Cfn.StringLiteral s →
220-
pure $ literalString $ decodeStringEscaping s
228+
pure $ LiteralString ann $ decodeStringEscaping s
221229
Cfn.CharLiteral c →
222-
pure $ literalChar c
230+
pure $ LiteralChar ann c
223231
Cfn.BooleanLiteral b →
224-
pure $ literalBool b
232+
pure $ LiteralBool ann b
225233
Cfn.ArrayLiteral exprs →
226-
literalArray <$> traverse makeExp exprs
234+
LiteralArray ann <$> traverse makeExpr exprs
227235
Cfn.ObjectLiteral kvs →
228-
literalObject <$> traverse (bitraverse mkPropName makeExp) kvs
236+
LiteralObject ann <$> traverse (bitraverse mkPropName makeExpr) kvs
229237

230238
mkConstructor
231239
∷ Cfn.Ann
240+
→ Ann
232241
→ PS.ProperName 'PS.TypeName
233242
→ PS.ProperName 'PS.ConstructorName
234243
→ [PS.Ident]
235244
→ RepM Exp
236-
mkConstructor ann properTyName properCtorName fields = do
245+
mkConstructor cfnAnn ann properTyName properCtorName fields = do
237246
let tyName = mkTyName properTyName
238247
contextModuleName ← gets (Cfn.moduleName . contextModule)
239248
algTy ← algebraicTy contextModuleName tyName
240249
pure
241-
if isNewtype ann
250+
if isNewtype cfnAnn
242251
then identity
243252
else
244253
Ctor
245-
noAnn
254+
ann
246255
algTy
247256
contextModuleName
248257
tyName
@@ -263,21 +272,21 @@ mkPropName str = case decodeString str of
263272
Left err → throwContextualError $ UnicodeDecodeError err
264273
Right decodedString → pure $ PropName decodedString
265274

266-
mkAccessor ∷ PSString → CfnExp → RepM Exp
267-
mkAccessor prop cfnExpr = do
275+
mkAccessor ∷ Ann → PSString → CfnExp → RepM Exp
276+
mkAccessor ann prop cfnExpr = do
268277
propName ← mkPropName prop
269-
makeExp cfnExpr <&> \expr → ObjectProp noAnn expr propName
278+
makeExprAnnotated ann cfnExpr <&> \expr → ObjectProp noAnn expr propName
270279

271280
mkObjectUpdate ∷ CfnExp → [(PSString, CfnExp)] → RepM Exp
272281
mkObjectUpdate cfnExp props = do
273-
expr ← makeExp cfnExp
274-
patch ← traverse (bitraverse mkPropName makeExp) props
282+
expr ← makeExpr cfnExp
283+
patch ← traverse (bitraverse mkPropName makeExpr) props
275284
case NE.nonEmpty patch of
276285
Nothing → throwContextualError EmptyObjectUpdate
277286
Just ps → pure $ ObjectUpdate noAnn expr ps
278287

279-
mkAbstraction ∷ PS.Ident → CfnExp → RepM Exp
280-
mkAbstraction i e = abstraction param <$> makeExp e
288+
mkAbstraction ∷ Ann → PS.Ident → CfnExp → RepM Exp
289+
mkAbstraction ann i e = Abs ann param <$> makeExpr e
281290
where
282291
param ∷ Parameter Ann =
283292
case PS.runIdent i of
@@ -287,8 +296,8 @@ mkAbstraction i e = abstraction param <$> makeExp e
287296
mkApplication ∷ CfnExp → CfnExp → RepM Exp
288297
mkApplication e1 e2 =
289298
if isNewtype (Cfn.extractAnn e1)
290-
then makeExp e2
291-
else application <$> makeExp e1 <*> makeExp e2
299+
then makeExpr e2
300+
else application <$> makeExpr e1 <*> makeExpr e2
292301

293302
mkQualifiedIdent ∷ PS.Qualified PS.Ident → RepM (Qualified Name)
294303
mkQualifiedIdent (PS.Qualified by ident) =
@@ -303,27 +312,27 @@ mkQualifiedIdent (PS.Qualified by ident) =
303312
mkRef ∷ PS.Qualified PS.Ident → RepM Exp
304313
mkRef = (\n → Ref noAnn n 0) <<$>> mkQualifiedIdent
305314

306-
mkLet ∷ [Cfn.Bind Cfn.Ann] → CfnExp → RepM Exp
307-
mkLet binds expr = do
308-
groupings ∷ NonEmpty (Grouping (Ann, Name, Exp)) ←
315+
mkLet ∷ Ann → [Cfn.Bind Cfn.Ann] → CfnExp → RepM Exp
316+
mkLet ann binds expr = do
317+
groupings ∷ NonEmpty Binding ←
309318
NE.nonEmpty binds
310-
& maybe (throwContextualError LetWithoutBinds) (traverse mkGrouping)
311-
lets groupings <$> makeExp expr
319+
& maybe (throwContextualError LetWithoutBinds) (traverse mkBinding)
320+
Let ann groupings <$> makeExpr expr
312321

313322
--------------------------------------------------------------------------------
314323
-- Case statements are compiled to a decision trees (nested if/else's) ---------
315324
-- The algorithm is based on this document: ------------------------------------
316325
-- https://julesjacobs.com/notes/patternmatching/patternmatching.pdf -----------
317326

318-
mkCase ∷ [CfnExp] → NonEmpty (Cfn.CaseAlternative Cfn.Ann) → RepM Exp
319-
mkCase cfnExpressions alternatives = do
320-
expressions ← traverse makeExp cfnExpressions
327+
mkCase ∷ Ann -> [CfnExp] → NonEmpty (Cfn.CaseAlternative Cfn.Ann) → RepM Exp
328+
mkCase ann cfnExpressions alternatives = do
329+
expressions ← traverse makeExpr cfnExpressions
321330
-- Before making clauses, we need to prepare bindings
322331
-- such that instead of repeating the same expression multiple times,
323332
-- we can bind it to a name once and then repeat references.
324333
(references, bindings) ← prepareBindings expressions
325334
clauses ← traverse (alternativeToClauses references) alternatives
326-
let addHeader = maybe id lets (NE.nonEmpty bindings)
335+
let addHeader = maybe id (Let ann) (NE.nonEmpty bindings)
327336
addHeader <$> mkCaseClauses (NE.toList clauses)
328337

329338
-- Either an expression to inline, or a named expression reference.
@@ -649,8 +658,8 @@ alternativeToClauses
649658

650659
clauseResult ←
651660
bitraverse
652-
(traverse (bitraverse makeExp makeExp))
653-
makeExp
661+
(traverse (bitraverse makeExpr makeExpr))
662+
makeExpr
654663
caseAlternativeResult
655664

656665
pure

‎lib/Language/PureScript/Backend/IR/DCE.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -7,15 +7,18 @@ import Data.List.NonEmpty qualified as NE
77
import Data.Map qualified as Map
88
import Data.Set qualified as Set
99
import Language.PureScript.Backend.IR.Linker (UberModule (..))
10+
import Language.PureScript.Backend.IR.Names
11+
( ModuleName
12+
, Name
13+
, QName (..)
14+
, Qualified (..)
15+
)
1016
import Language.PureScript.Backend.IR.Types
1117
( Ann
1218
, Exp
1319
, Grouping (..)
1420
, Index
15-
, Name
1621
, Parameter (..)
17-
, QName (..)
18-
, Qualified (..)
1922
, RawExp (..)
2023
, RewriteMod (..)
2124
, Rewritten (..)
@@ -24,7 +27,6 @@ import Language.PureScript.Backend.IR.Types
2427
, listGrouping
2528
, rewriteExpTopDown
2629
)
27-
import Language.PureScript.Names (ModuleName)
2830

2931
data EntryPoint = EntryPoint ModuleName [Name]
3032
deriving stock (Show)

‎lib/Language/PureScript/Backend/IR/Inliner.hs‎

Lines changed: 15 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,13 @@
11
module Language.PureScript.Backend.IR.Inliner where
22

3+
import Control.Monad.Combinators (choice)
4+
import Language.PureScript.Backend.IR.Names (Name, nameParser)
35
import Text.Megaparsec qualified as Megaparsec
46
import Text.Megaparsec.Char qualified as MC
57
import Text.Megaparsec.Char.Lexer qualified as ML
68

9+
type Pragma = (Name, Annotation)
10+
711
data Annotation = Annotation InlineScope InlineRecipe
812
deriving stock (Show, Eq, Ord)
913

@@ -15,13 +19,17 @@ data InlineRecipe = Default | Always | Never
1519

1620
type Parser = Megaparsec.Parsec Void Text
1721

22+
pragmaParser ∷ Parser Pragma
23+
pragmaParser = do
24+
symbol "@inline"
25+
(,) <$> (nameParser <* sc) <*> annotationParser
26+
1827
annotationParser ∷ Parser Annotation
19-
annotationParser =
20-
symbol "@inline" *> (Annotation <$> scopeParser <*> recipeParser)
28+
annotationParser = Annotation <$> scopeParser <*> recipeParser
2129

2230
recipeParser ∷ Parser InlineRecipe
2331
recipeParser =
24-
asum
32+
choice
2533
[ Default <$ symbol "default"
2634
, Always <$ symbol "always"
2735
, Never <$ symbol "never"
@@ -31,4 +39,7 @@ scopeParser ∷ Parser InlineScope
3139
scopeParser = maybe InModule (const Global) <$> optional (symbol "export")
3240

3341
symbol ∷ Text → Parser ()
34-
symbol = void . ML.symbol (ML.space (MC.hspace1 @_ @Text) empty empty)
42+
symbol = void . ML.symbol sc
43+
44+
sc ∷ Parser ()
45+
sc = ML.space (MC.hspace1 @_ @Text) empty empty

‎lib/Language/PureScript/Backend/IR/Linker.hs‎

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -4,25 +4,27 @@ module Language.PureScript.Backend.IR.Linker where
44

55
import Data.Graph (graphFromEdges', reverseTopSort)
66
import Data.Map qualified as Map
7+
import Language.PureScript.Backend.IR.Names
8+
( ModuleName
9+
, Name (..)
10+
, PropName (PropName)
11+
, QName (QName)
12+
, Qualified (Imported, Local)
13+
)
714
import Language.PureScript.Backend.IR.Types
815
( Ann
916
, Binding
1017
, Exp
1118
, Grouping (..)
1219
, Index
1320
, Module (..)
14-
, Name (..)
1521
, Parameter (ParamNamed, ParamUnused)
16-
, PropName (..)
17-
, QName (QName)
18-
, Qualified (Imported, Local)
1922
, RawExp (..)
2023
, bindingNames
2124
, noAnn
2225
, objectProp
2326
, refImported
2427
)
25-
import Language.PureScript.Names (ModuleName)
2628

2729
--------------------------------------------------------------------------------
2830
-- Data ------------------------------------------------------------------------

0 commit comments

Comments
 (0)