fb19899 · elk · git.iko.soy

git.iko.soy/elk

Get pattern matching working on Bool values

commitfb19899c1d07ea8f772c69a0cd30bf6eb680409a authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 18 May 2018, 08:33 (8 years ago) parentecdf1f4

9 files changed+78−14

compare with master

unifiedsplit

compiler/src/AST/Canonical.hs+1 compiler/src/Canonicalize/Pattern.hs+5−1 compiler/src/Elm/Name.hs+11−1 compiler/src/Generate/JavaScript/Expression.hs+27−12 compiler/src/Nitpick/PatternMatches.hs+3 compiler/src/Optimize/DecisionTree.hs+21 compiler/src/Optimize/Expression.hs+3 compiler/src/Reporting/Error/Type.hs+2 compiler/src/Type/Constrain/Pattern.hs+5

compiler/src/AST/Canonical.hs+1

@@ -152,6 +152,7 @@ data Pattern_

152152 | PTuple Pattern Pattern (Maybe Pattern)

153153 | PList [Pattern]

154154 | PCons Pattern Pattern

155+ | PBool Union Bool

155156 | PChr Text

156157 | PStr Text

157158 | PInt Int

compiler/src/Canonicalize/Pattern.hs+5−1

@@ -11,6 +11,7 @@ module Canonicalize.Pattern

1111import qualified Data.Map.Strict as Map

1212

1313import qualified AST.Canonical as Can

14+import qualified AST.Module.Name as ModuleName

1415import qualified AST.Source as Src

1516import qualified Canonicalize.Environment as Env

1617import qualified Canonicalize.Environment.Dups as Dups

@@ -123,7 +124,10 @@ canonicalizeCtor env region name patterns ctor =

123124 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

124125 case verifiedList of

125126 Index.LengthMatch cargs ->

126− Result.ok (Can.PCtor home tipe union name index cargs)

127+ if tipe == N.bool && home == ModuleName.basics then

128+ Result.ok (Can.PBool union (name == N.true))

129+ else

130+ Result.ok (Can.PCtor home tipe union name index cargs)

127131

128132 Index.LengthMismatch actualLength expectedLength ->

129133 Result.throw (Error.BadArity region Error.PatternArity name actualLength expectedLength)

compiler/src/Elm/Name.hs+11−1

@@ -28,7 +28,7 @@ module Elm.Name

2828 , maybe, result, list, array, dict, tuple, jsArray

2929 , task, router, cmd, sub, platform, browser, virtualDom

3030 , shader, debug, debugger, bitwise, basics

31− , utils, negate, value

31+ , utils, negate, true, false, value

3232 , node, program, main, dollar, identity

3333 , replModule

3434 )

@@ -302,6 +302,16 @@ negate :: Name

302302negate = "negate"

303303

304304

305+{-# NOINLINE true #-}

306+true :: Name

307+true = "True"

308+

309+

310+{-# NOINLINE false #-}

311+false :: Name

312+false = "False"

313+

314+

305315{-# NOINLINE value #-}

306316value :: Name

307317value = "Value"

compiler/src/Generate/JavaScript/Expression.hs+27−12

@@ -899,6 +899,12 @@ generateIfTest mode root (path, test) =

899899 Mode.Dev _ _ -> JS.String (N.toBuilder name)

900900 Mode.Prod _ _ -> JS.Int (ctorToInt home name index)

901901

902+ DT.IsBool True ->

903+ value

904+

905+ DT.IsBool False ->

906+ JS.Prefix JS.PrefixLNot value

907+

902908 DT.IsInt int ->

903909 strictEq value (JS.Int int)

904910

@@ -947,6 +953,9 @@ generateCaseValue mode test =

947953 DT.IsStr string ->

948954 JS.String (Text.encodeUtf8Builder string)

949955

956+ DT.IsBool _ ->

957+ error "COMPILER BUG - there should never be three tests on a boolean"

958+

950959 DT.IsCons ->

951960 error "COMPILER BUG - there should never be three tests on a list"

952961

@@ -963,21 +972,24 @@ generateCaseTest mode root path exampleTest =

963972 value = pathToJsExpr mode root path

964973 in

965974 case exampleTest of

966− DT.IsCtor _ _ _ _ opts ->

967− case mode of

968− Mode.Dev _ _ ->

969− JS.Access value Name.dollar

975+ DT.IsCtor home name _ _ opts ->

976+ if name == N.bool && home == ModuleName.basics then

977+ value

978+ else

979+ case mode of

980+ Mode.Dev _ _ ->

981+ JS.Access value Name.dollar

970982

971− Mode.Prod _ _ ->

972− case opts of

973− Can.Normal ->

974− JS.Access value Name.dollar

983+ Mode.Prod _ _ ->

984+ case opts of

985+ Can.Normal ->

986+ JS.Access value Name.dollar

975987

976− Can.Enum ->

977− value

988+ Can.Enum ->

989+ value

978990

979− Can.Unbox ->

980− value

991+ Can.Unbox ->

992+ value

981993

982994 DT.IsInt _ ->

983995 value

@@ -993,6 +1005,9 @@ generateCaseTest mode root path exampleTest =

9931005 Mode.Prod _ _ ->

9941006 value

9951007

1008+ DT.IsBool _ ->

1009+ error "COMPILER BUG - there should never be three tests on a list"

1010+

9961011 DT.IsCons ->

9971012 error "COMPILER BUG - there should never be three tests on a list"

9981013

compiler/src/Nitpick/PatternMatches.hs+3

@@ -94,6 +94,9 @@ simplify (A.At _ pattern) =

9494 Can.PChr chr ->

9595 Literal (Chr chr)

9696

97+ Can.PBool union bool ->

98+ Ctor union (if bool then N.true else N.false) []

99+

97100

98101cons :: Can.Pattern -> Pattern -> Pattern

99102cons hd tl =

compiler/src/Optimize/DecisionTree.hs+21

@@ -79,6 +79,7 @@ data Test

7979 | IsInt Int

8080 | IsChr Text

8181 | IsStr Text

82+ | IsBool Bool

8283 deriving (Eq, Ord)

8384

8485

@@ -159,6 +160,9 @@ isComplete tests =

159160 IsInt _ ->

160161 False

161162

163+ IsBool _ ->

164+ length tests == 2

165+

162166

163167

164168-- FLATTEN PATTERNS

@@ -227,6 +231,9 @@ flatten pathPattern@(path, A.At region pattern) otherPathPatterns =

227231 Can.PInt _ ->

228232 pathPattern : otherPathPatterns

229233

234+ Can.PBool _ _ ->

235+ pathPattern : otherPathPatterns

236+

230237

231238subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]

232239subPositions path patterns =

@@ -338,6 +345,9 @@ testAtPath selectedPath (Branch _ pathPatterns) =

338345 Can.PChr chr ->

339346 Just (IsChr chr)

340347

348+ Can.PBool _ bool ->

349+ Just (IsBool bool)

350+

341351 Can.PRecord _ ->

342352 Nothing

343353

@@ -423,6 +433,14 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =

423433 _ ->

424434 Nothing

425435

436+ Can.PBool _ bool ->

437+ case test of

438+ IsBool testBool | bool == testBool ->

439+ Just (Branch goal (start ++ end))

440+

441+ _ ->

442+ Nothing

443+

426444 Can.PUnit ->

427445 Just (Branch goal (start ++ end))

428446

@@ -497,6 +515,7 @@ needsTests (A.At _ pattern) =

497515 Can.PChr _ -> True

498516 Can.PStr _ -> True

499517 Can.PInt _ -> True

518+ Can.PBool _ _ -> True

500519 Can.PAlias _ _ ->

501520 error "aliases should never reach 'isIrrelevantTo' function"

502521

@@ -586,6 +605,7 @@ instance Binary Test where

586605 IsChr a -> putWord8 4 >> put a

587606 IsStr a -> putWord8 5 >> put a

588607 IsInt a -> putWord8 6 >> put a

608+ IsBool a -> putWord8 7 >> put a

589609

590610 get =

591611 do word <- getWord8

@@ -597,6 +617,7 @@ instance Binary Test where

597617 4 -> liftM IsChr get

598618 5 -> liftM IsStr get

599619 6 -> liftM IsInt get

620+ 7 -> liftM IsBool get

600621 _ -> error "problem getting DecisionTree.Test binary"

601622

602623

compiler/src/Optimize/Expression.hs+3

@@ -298,6 +298,9 @@ destructHelp path (A.At region pattern) revDs =

298298 Can.PInt _ ->

299299 pure revDs

300300

301+ Can.PBool _ _ ->

302+ pure revDs

303+

301304 Can.PCtor _ _ (Can.Union _ _ _ opts) _ _ args ->

302305 case args of

303306 [Can.PatternCtorArg _ _ arg] ->

compiler/src/Reporting/Error/Type.hs+2

@@ -132,6 +132,7 @@ data PCategory

132132 | PInt

133133 | PStr

134134 | PChr

135+ | PBool

135136

136137

137138

@@ -302,6 +303,7 @@ addPatternCategory iAmTryingToMatch category =

302303 PInt -> " integers:"

303304 PStr -> " strings:"

304305 PChr -> " characters:"

306+ PBool -> " booleans:"

305307

306308

307309

compiler/src/Type/Constrain/Pattern.hs+5

@@ -122,6 +122,11 @@ add (A.At region pattern) expectation state =

122122 let chrCon = CPattern region E.PChr T.char expectation

123123 return $ State headers vars (chrCon:revCons)

124124

125+ Can.PBool _ _ ->

126+ do let (State headers vars revCons) = state

127+ let boolCon = CPattern region E.PBool T.bool expectation

128+ return $ State headers vars (boolCon:revCons)

129+

125130

126131

127132-- STATE HELPERS