@@ -67,10 +67,11 @@ import Data.Semigroup.Foldable (maximum)
6767import Data.Set (Set)
6868import Data.Set as Set
6969import Data.Traversable (class Foldable, Accum, foldr, for, mapAccumL, mapAccumR, sequence, traverse)
70+import Data.TraversableWithIndex (forWithIndex)
7071import Data.Tuple (Tuple(..), fst, snd)
7172import Partial.Unsafe (unsafeCrashWith, unsafePartial)
7273import PureScript.Backend.Optimizer.Analysis (BackendAnalysis)
73−import PureScript.Backend.Optimizer.CoreFn (Ann(..), Bind(..), Binder(..), Binding(..), CaseAlternative(..), CaseGuard(..), Comment, ConstructorType(..), Expr(..), Guard(..), Ident(..), Literal(..), Meta(..), Module(..), ModuleName(..), ProperName, Qualified(..), ReExport, findProp, propKey, propValue, qualifiedModuleName)
74+import PureScript.Backend.Optimizer.CoreFn (Ann(..), Bind(..), Binder(..), Binding(..), CaseAlternative(..), CaseGuard(..), Comment, ConstructorType(..), Expr(..), Guard(..), Ident(..), Literal(..), Meta(..), Module(..), ModuleName(..), ProperName, Qualified(..), ReExport, findProp, propKey, propValue, qualifiedModuleName, unQualified)
7475import PureScript.Backend.Optimizer.Directives (DirectiveHeaderResult, parseDirectiveHeader)
7576import PureScript.Backend.Optimizer.Semantics (BackendExpr(..), BackendSemantics, Ctx, DataTypeMeta, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, NeutralExpr(..), build, evalExternFromImpl, freeze, optimize)
7677import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval)
@@ -454,8 +455,8 @@ toBackendExpr = case _ of
454455 toInitialCaseRows idents alts useCaseRowsCb =
455456 foldr
456457 ( \(CaseAlternative bs g) mainCb caseRows -> do
458+ patterns <- Array.zipWithA (\ident b -> { column: ident, pattern: _ } <$> binderToPattern b) idents bs
457459 let
458− patterns = Array.zipWith (\ident b -> { column: ident, pattern: binderToPattern b }) idents bs
459460 args = Array.sort $ foldMap patternVars patterns
460461 buildCaseRow guardFn = { patterns, guardFn, vars: SemigroupMap Map.empty }
461462
@@ -533,14 +534,13 @@ data PatternCase
533534derive instance Eq PatternCase
534535derive instance Ord PatternCase
535536
536−binderToPattern :: Binder Ann -> Pattern
537+binderToPattern :: Binder Ann -> ConvertM Pattern
537538binderToPattern = case _ of
538539 BinderNull _ -> primitivePattern PatWild
539540 BinderVar _ var ->
540− Pattern { vars: Set.singleton var, patternCase: PatWild, subterms: [] }
541− BinderNamed _ var next -> do
542− let (Pattern r) = binderToPattern next
543− Pattern r { vars = Set.insert var r.vars }
541+ pure $ Pattern { vars: Set.singleton var, patternCase: PatWild, subterms: [] }
542+ BinderNamed _ var next ->
543+ map (over Pattern \r -> r { vars = Set.insert var r.vars }) $ binderToPattern next
544544 BinderLit _ lit -> case lit of
545545 LitInt a -> primitivePattern $ PatInt a
546546 LitNumber a -> primitivePattern $ PatNumber a
@@ -570,25 +570,29 @@ binderToPattern = case _ of
570570 binderToPattern arg
571571 | otherwise ->
572572 unsafeCrashWith "Newtype binder didn't wrap 1 arg"
573− Just (IsConstructor ProductType _) ->
573+ Just (IsConstructor ProductType _) -> do
574+ ctorFields <- lookupCtorFields tyName ctorName
575+ let argsWithNames = Array.zip args ctorFields
574576 -- We cannot safely expand the fields here because the number of columns
575577 -- would change. So, any later rows' `BinderNull` or `BinderVar` would not similarly be expanded.
576578 ctorPattern
577579 (PatProduct tyName ctorName)
578− args
579− (\idx _ -> GetOffset idx)
580− identity
581− Just (IsConstructor SumType _) ->
580+ argsWithNames
581+ (\idx (Tuple _ fieldName) -> GetCtorField ctorName ProductType (unQualified tyName) (unQualified ctorName) fieldName idx)
582+ fst
583+ Just (IsConstructor SumType _) -> do
584+ ctorFields <- lookupCtorFields tyName ctorName
585+ let argsWithNames = Array.zip args ctorFields
582586 ctorPattern
583587 (PatSum tyName ctorName)
584− args
585− (\idx _ -> GetOffset idx)
586− identity
588+ argsWithNames
589+ (\idx (Tuple _ fieldName) -> GetCtorField ctorName SumType (unQualified tyName) (unQualified ctorName) fieldName idx)
590+ fst
587591 _ ->
588592 unsafeCrashWith "binderToPattern - invalid meta"
589593 where
590− primitivePattern :: PatternCase -> Pattern
591− primitivePattern patternCase = Pattern { vars: Set.empty, patternCase, subterms: [] }
594+ primitivePattern :: PatternCase -> ConvertM Pattern
595+ primitivePattern patternCase = pure $ Pattern { vars: Set.empty, patternCase, subterms: [] }
592596
593597 ctorPattern
594598 :: forall a
@@ -596,15 +600,35 @@ binderToPattern = case _ of
596600 -> Array a
597601 -> (Int -> a -> BackendAccessor)
598602 -> (a -> Binder Ann)
599− -> Pattern
600− ctorPattern patternCase args buildAccessor toBinder = Pattern
601− { vars: Set.empty
602− , patternCase
603− , subterms: args # mapWithIndex \idx nextArg ->
604− { accessor: buildAccessor idx nextArg
605− , pattern: binderToPattern $ toBinder nextArg
603+ -> ConvertM Pattern
604+ ctorPattern patternCase args buildAccessor toBinder = ado
605+ subterms <- forWithIndex args \idx nextArg -> ado
606+ pattern <- binderToPattern $ toBinder nextArg
607+ in { accessor: buildAccessor idx nextArg, pattern }
608+ in
609+ Pattern
610+ { vars: Set.empty
611+ , patternCase
612+ , subterms
606613 }
607− }
614+
615+ lookupCtorFields
616+ :: Qualified ProperName
617+ -> Qualified Ident
618+ -> ConvertM (Array String)
619+ lookupCtorFields ty ctor = do
620+ { dataTypes, implementations } <- ask
621+ case importedCtorFields implementations <|> localCtorFields dataTypes of
622+ Just fields -> pure fields
623+ Nothing -> unsafeCrashWith "Invariant broken: could not determine pattern matched constructor's fields during conversion."
624+ where
625+ importedCtorFields implementations = case Map.lookup ctor implementations of
626+ Just (Tuple _ (ExternCtor _ _ _ _ fields)) -> Just fields
627+ _ -> Nothing
628+
629+ localCtorFields dataTypes = do
630+ { constructors } <- Map.lookup (unQualified ty) dataTypes
631+ _.fields <$> Map.lookup (unQualified ctor) constructors
608632
609633patternVars :: forall r. { pattern :: Pattern | r } -> Array Ident
610634patternVars { pattern: Pattern { vars, subterms } } =