a672aa7 · elk · git.iko.soy

git.iko.soy/elk

Upgrade Nitpick code from String to Text

commita672aa74e6c23757b50fe6de5b24cb945c5be9a2 authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 5 Dec 2016, 21:31 (10 years ago) parente07d16b

3 files changed+39−25

compare with master

unifiedsplit

src/Nitpick/Pattern.hs+22−13 src/Nitpick/PatternMatches.hs+9−6 src/Nitpick/TopLevelTypes.hs+8−6

src/Nitpick/Pattern.hs+22−13

@@ -1,4 +1,5 @@

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

23module Nitpick.Pattern

34 ( Pattern(..)

45 , fromCanonicalPattern

@@ -7,6 +8,9 @@ module Nitpick.Pattern

78 where

910import qualified Data.List as List

11+import Data.Monoid ((<>))

12+import qualified Data.Text.Lazy as LazyText

13+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)

1014

1115import qualified AST.Literal as L

1216import qualified AST.Pattern as P

@@ -28,7 +32,7 @@ data Pattern

2832fromCanonicalPattern :: P.Canonical -> Pattern

2933fromCanonicalPattern (A.A _ pattern) =

3034 case pattern of

31− P.Data name patterns ->

35+ P.Ctor name patterns ->

3236 Ctor name (map fromCanonicalPattern patterns)

3337

3438 P.Record _ ->

@@ -57,34 +61,39 @@ fromCanonicalPattern (A.A _ pattern) =

5761-- TO STRING

5862

5963

60−toString :: Bool -> Pattern -> String

61−toString needsParens pattern =

64+toString :: Pattern -> String

65+toString pattern =

66+ LazyText.unpack (toLazyText (toBuilder False pattern))

67+

68+

69+toBuilder :: Bool -> Pattern -> Builder

70+toBuilder needsParens pattern =

6271 case pattern of

63− Ctor tag [first,rest] | Var.toString tag == "::" ->

64− toString (isCons first) first

65− ++ " :: "

66− ++ toString False rest

72+ Ctor tag [first,rest] | Var.toText tag == "::" ->

73+ toBuilder (isCons first) first <> " :: " <> toBuilder False rest

6774

6875 Ctor tag args ->

6976 if Var.isTuple tag then

7077 if null args then "()" else

71− "( " ++ List.intercalate ", " (map (toString False) args) ++ " )"

78+ "( "

79+ <> mconcat (List.intersperse ", " (map (toBuilder False) args))

80+ <> " )"

7281

7382 else

7483 addParensIf (needsParens && not (null args)) $

75− List.intercalate " " (Var.toString tag : map (toString True) args)

84+ mconcat (List.intersperse " " (fromText (Var.toText tag) : map (toBuilder True) args))

7685

7786 Anything ->

7887 "_"

7988

8089 Literal literal ->

81− L.toString literal

90+ L.toBuilder literal

8291

8392

84−addParensIf :: Bool -> String -> String

93+addParensIf :: Bool -> Builder -> Builder

8594addParensIf needsParens str =

8695 if needsParens then

87− "(" ++ str ++ ")"

96+ "(" <> str <> ")"

8897

8998 else

9099 str

@@ -94,7 +103,7 @@ isCons :: Pattern -> Bool

94103isCons pattern =

95104 case pattern of

96105 Ctor tag [_,_] ->

97− Var.toString tag == "::"

106+ Var.toText tag == "::"

98107

99108 _ ->

100109 False

src/Nitpick/PatternMatches.hs+9−6

@@ -1,4 +1,5 @@

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

23module Nitpick.PatternMatches (patternMatches) where

45{- The algorithm used here comes from "Warnings for Pattern Matching"

@@ -14,6 +15,8 @@ import qualified Data.List as List

1415import qualified Data.Map as Map

1516import qualified Data.Maybe as Maybe

1617import qualified Data.Set as Set

18+import qualified Data.Text as Text

19+import Data.Text (Text)

1720

1821import qualified AST.Expression.Canonical as C

1922import qualified AST.Helpers as Help

@@ -379,7 +382,7 @@ isCompleteHelp ctors row =

379382

380383

381384type ArityDict =

382− Map.Map Var.Home (Map.Map String ArityInfo)

385+ Map.Map Var.Home (Map.Map Text ArityInfo)

383386

384387

385388data ArityInfo =

@@ -416,21 +419,21 @@ builtinDict =

416419 ++ map makeTupleInfo [0..8]

417420

418421

419−makeTupleInfo :: Int -> ( String, ArityInfo )

422+makeTupleInfo :: Int -> ( Text, ArityInfo )

420423makeTupleInfo n =

421424 let

422425 name =

423− "_Tuple" ++ show n

426+ Text.pack ("_Tuple" ++ show n)

424427 in

425428 ( name, ArityInfo 1 [ (Var.builtin name, n) ] )

426429

427430

428−toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map String ArityInfo

431+toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map Text ArityInfo

429432toArityEntry name unions =

430433 Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))

431434

432435

433−toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo String -> [(String, ArityInfo)]

436+toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo Text -> [(Text, ArityInfo)]

434437toArityEntryHelp name (_tvars, ctors) =

435438 let

436439 arityInfo =

@@ -447,7 +450,7 @@ getArityInfo var@(Var.Canonical home name) arityDict =

447450

448451 Nothing ->

449452 if Help.isTuple name then

450− ArityInfo 1 [ (var, read (drop 6 name)) ]

453+ ArityInfo 1 [ (var, read (drop 6 (Text.unpack name))) ]

451454 else

452455 error

453456 "Since the Nitpick phase happens after canonicalization and type\

src/Nitpick/TopLevelTypes.hs+8−6

@@ -1,9 +1,11 @@

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

23module Nitpick.TopLevelTypes (topLevelTypes) where

45import qualified Data.Foldable as F

56import Data.Map ((!))

67import qualified Data.Map as Map

8+import qualified Data.Text as Text

810import qualified AST.Expression.Canonical as Can

911import qualified AST.Module.Name as ModuleName

@@ -24,7 +26,7 @@ type Result =

2426

2527

2628type TypeDict =

27− Map.Map String Type.Canonical

29+ Map.Map Var.Canonical Type.Canonical

2830

2931

3032

@@ -62,7 +64,7 @@ checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =

6264 (P.Var name, Nothing) ->

6365 let

6466 warning =

65− Warning.MissingTypeAnnotation name (typeEnv ! name)

67+ Warning.MissingTypeAnnotation (Text.unpack name) (typeEnv ! Var.local name)

6668 in

6769 Result.warn region warning ()

6870

@@ -78,7 +80,7 @@ checkMain :: TypeDict -> Can.Def -> Result Can.Def

7880checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

7981 let

8082 mainType =

81− typeEnv ! "main"

83+ typeEnv ! Var.local "main"

8284

8385 makeError tipe maybeMsg =

8486 A.A region (Error.BadFlags tipe maybeMsg)

@@ -107,19 +109,19 @@ checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

107109

108110program :: Type.Canonical

109111program =

110− Type.Type (Var.inCore ["Platform"] "Program")

112+ Type.Type (Var.inCore "Platform" "Program")

111113

112114

113115never :: Type.Canonical

114116never =

115− Type.Type (Var.inCore ["Basics"] "Never")

117+ Type.Type (Var.inCore "Basics" "Never")

116118

117119

118120vdomNode :: Type.Canonical

119121vdomNode =

120122 let

121123 vdom =

122− ModuleName.Canonical Pkg.virtualDom ["VirtualDom"]

124+ ModuleName.Canonical Pkg.virtualDom "VirtualDom"

123125 in

124126 Type.Type (Var.fromModule vdom "Node")

125127