fb19899 · elk · git.iko.soy

compiler/src/AST/Canonical.hs+1

compare with master

unifiedsplit

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

152 | PTuple Pattern Pattern (Maybe Pattern)

153 | PList [Pattern]

154 | PCons Pattern Pattern

155+ | PBool Union Bool

155 | PChr Text

156 | PChr Text

156 | PStr Text

157 | PStr Text

157 | PInt Int

158 | PInt Int

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

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

11import qualified Data.Map.Strict as Map

12

13import qualified AST.Canonical as Can

14+import qualified AST.Module.Name as ModuleName

14import qualified AST.Source as Src

15import qualified AST.Source as Src

15import qualified Canonicalize.Environment as Env

16import qualified Canonicalize.Environment as Env

16import qualified Canonicalize.Environment.Dups as Dups

17import qualified Canonicalize.Environment.Dups as Dups

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

123 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

124 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

124 case verifiedList of

125 case verifiedList of

125 Index.LengthMatch cargs ->

126 Index.LengthMatch cargs ->

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

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

129+ else

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

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

127

131

128 Index.LengthMismatch actualLength expectedLength ->

132 Index.LengthMismatch actualLength expectedLength ->

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

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

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

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

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

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

30 , shader, debug, debugger, bitwise, basics

31− , utils, negate, value

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

32 , node, program, main, dollar, identity

33 , replModule

34 )

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

302negate = "negate"

303

304

305+{-# NOINLINE true #-}

306+true :: Name

307+true = "True"

308+

309+

310+{-# NOINLINE false #-}

311+false :: Name

312+false = "False"

313+

314+

305{-# NOINLINE value #-}

315{-# NOINLINE value #-}

306value :: Name

316value :: Name

307value = "Value"

317value = "Value"

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

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

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

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

901

902+ DT.IsBool True ->

903+ value

904+

905+ DT.IsBool False ->

906+ JS.Prefix JS.PrefixLNot value

907+

902 DT.IsInt int ->

908 DT.IsInt int ->

903 strictEq value (JS.Int int)

909 strictEq value (JS.Int int)

904

910

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

947 DT.IsStr string ->

953 DT.IsStr string ->

948 JS.String (Text.encodeUtf8Builder string)

954 JS.String (Text.encodeUtf8Builder string)

949

955

956+ DT.IsBool _ ->

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

958+

950 DT.IsCons ->

959 DT.IsCons ->

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

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

952

961

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

963 value = pathToJsExpr mode root path

972 value = pathToJsExpr mode root path

964 in

973 in

965 case exampleTest of

974 case exampleTest of

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

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

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

977+ value

978+ else

967− case mode of

979+ case mode of

968− Mode.Dev _ _ ->

980+ Mode.Dev _ _ ->

969− JS.Access value Name.dollar

981+ JS.Access value Name.dollar

970

982

971− Mode.Prod _ _ ->

983+ Mode.Prod _ _ ->

972− case opts of

984+ case opts of

973− Can.Normal ->

985+ Can.Normal ->

974− JS.Access value Name.dollar

986+ JS.Access value Name.dollar

975

987

976− Can.Enum ->

988+ Can.Enum ->

977− value

989+ value

978

990

979− Can.Unbox ->

991+ Can.Unbox ->

980− value

992+ value

981

993

982 DT.IsInt _ ->

994 DT.IsInt _ ->

983 value

995 value

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

993 Mode.Prod _ _ ->

1005 Mode.Prod _ _ ->

994 value

1006 value

995

1007

1008+ DT.IsBool _ ->

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

1010+

996 DT.IsCons ->

1011 DT.IsCons ->

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

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

998

1013

compiler/src/Nitpick/PatternMatches.hs+3

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

94 Can.PChr chr ->

95 Literal (Chr chr)

96

97+ Can.PBool union bool ->

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

99+

97

100

98cons :: Can.Pattern -> Pattern -> Pattern

101cons :: Can.Pattern -> Pattern -> Pattern

99cons hd tl =

102cons hd tl =

compiler/src/Optimize/DecisionTree.hs+21

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

79 | IsInt Int

80 | IsChr Text

81 | IsStr Text

82+ | IsBool Bool

82 deriving (Eq, Ord)

83 deriving (Eq, Ord)

83

84

85

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

159 IsInt _ ->

160 IsInt _ ->

160 False

161 False

161

162

163+ IsBool _ ->

164+ length tests == 2

165+

162

166

163

167

164-- FLATTEN PATTERNS

168-- FLATTEN PATTERNS

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

227 Can.PInt _ ->

231 Can.PInt _ ->

228 pathPattern : otherPathPatterns

232 pathPattern : otherPathPatterns

229

233

234+ Can.PBool _ _ ->

235+ pathPattern : otherPathPatterns

236+

230

237

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

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

232subPositions path patterns =

239subPositions path patterns =

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

338 Can.PChr chr ->

345 Can.PChr chr ->

339 Just (IsChr chr)

346 Just (IsChr chr)

340

347

348+ Can.PBool _ bool ->

349+ Just (IsBool bool)

350+

341 Can.PRecord _ ->

351 Can.PRecord _ ->

342 Nothing

352 Nothing

343

353

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

423 _ ->

433 _ ->

424 Nothing

434 Nothing

425

435

436+ Can.PBool _ bool ->

437+ case test of

438+ IsBool testBool | bool == testBool ->

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

440+

441+ _ ->

442+ Nothing

443+

426 Can.PUnit ->

444 Can.PUnit ->

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

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

428

446

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

497 Can.PChr _ -> True

515 Can.PChr _ -> True

498 Can.PStr _ -> True

516 Can.PStr _ -> True

499 Can.PInt _ -> True

517 Can.PInt _ -> True

518+ Can.PBool _ _ -> True

500 Can.PAlias _ _ ->

519 Can.PAlias _ _ ->

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

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

502

521

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

586 IsChr a -> putWord8 4 >> put a

605 IsChr a -> putWord8 4 >> put a

587 IsStr a -> putWord8 5 >> put a

606 IsStr a -> putWord8 5 >> put a

588 IsInt a -> putWord8 6 >> put a

607 IsInt a -> putWord8 6 >> put a

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

589

609

590 get =

610 get =

591 do word <- getWord8

611 do word <- getWord8

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

597 4 -> liftM IsChr get

617 4 -> liftM IsChr get

598 5 -> liftM IsStr get

618 5 -> liftM IsStr get

599 6 -> liftM IsInt get

619 6 -> liftM IsInt get

620+ 7 -> liftM IsBool get

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

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

601

622

602

623

compiler/src/Optimize/Expression.hs+3

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

298 Can.PInt _ ->

299 pure revDs

300

301+ Can.PBool _ _ ->

302+ pure revDs

303+

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

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

302 case args of

305 case args of

303 [Can.PatternCtorArg _ _ arg] ->

306 [Can.PatternCtorArg _ _ arg] ->

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

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

132 | PInt

133 | PStr

134 | PChr

135+ | PBool

135

136

137

138

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

302 PInt -> " integers:"

303 PInt -> " integers:"

303 PStr -> " strings:"

304 PStr -> " strings:"

304 PChr -> " characters:"

305 PChr -> " characters:"

306+ PBool -> " booleans:"

305

307

306

308

307

309

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

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

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

123 return $ State headers vars (chrCon:revCons)

124

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+

125

130

126

131

127-- STATE HELPERS

132-- STATE HELPERS