git.iko.soy/elk
on master help sign in
Upgrade Nitpick code from String to Text
a672aa7Evan Czaplicki
src/Nitpick/Pattern.hs+22−13
compare with master
unifiedsplit
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module Nitpick.Pattern
3module Nitpick.Pattern
3 ( Pattern(..)
4 ( Pattern(..)
4 , fromCanonicalPattern
5 , fromCanonicalPattern
@@ -7,6 +8,9 @@ module Nitpick.Pattern
7 where
8 where
8
9
9import qualified Data.List as List
10import 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)
10
14
11import qualified AST.Literal as L
15import qualified AST.Literal as L
12import qualified AST.Pattern as P
16import qualified AST.Pattern as P
@@ -28,7 +32,7 @@ data Pattern
28fromCanonicalPattern :: P.Canonical -> Pattern
32fromCanonicalPattern :: P.Canonical -> Pattern
29fromCanonicalPattern (A.A _ pattern) =
33fromCanonicalPattern (A.A _ pattern) =
30 case pattern of
34 case pattern of
31− P.Data name patterns ->
35+ P.Ctor name patterns ->
32 Ctor name (map fromCanonicalPattern patterns)
36 Ctor name (map fromCanonicalPattern patterns)
33
37
34 P.Record _ ->
38 P.Record _ ->
@@ -57,34 +61,39 @@ fromCanonicalPattern (A.A _ pattern) =
57-- TO STRING
61-- TO STRING
58
62
59
63
64+toString :: Pattern -> String
65+toString pattern =
66+ LazyText.unpack (toLazyText (toBuilder False pattern))
67+
68+
60−toString :: Bool -> Pattern -> String
69+toBuilder :: Bool -> Pattern -> Builder
61−toString needsParens pattern =
70+toBuilder needsParens pattern =
62 case pattern of
71 case pattern of
63− Ctor tag [first,rest] | Var.toString tag == "::" ->
72+ Ctor tag [first,rest] | Var.toText tag == "::" ->
64− toString (isCons first) first
73+ toBuilder (isCons first) first <> " :: " <> toBuilder False rest
65− ++ " :: "
66− ++ toString False rest
67
74
68 Ctor tag args ->
75 Ctor tag args ->
69 if Var.isTuple tag then
76 if Var.isTuple tag then
70 if null args then "()" else
77 if null args then "()" else
78+ "( "
71− "( " ++ List.intercalate ", " (map (toString False) args) ++ " )"
79+ <> mconcat (List.intersperse ", " (map (toBuilder False) args))
80+ <> " )"
72
81
73 else
82 else
74 addParensIf (needsParens && not (null args)) $
83 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))
76
85
77 Anything ->
86 Anything ->
78 "_"
87 "_"
79
88
80 Literal literal ->
89 Literal literal ->
81− L.toString literal
90+ L.toBuilder literal
82
91
83
92
84−addParensIf :: Bool -> String -> String
93+addParensIf :: Bool -> Builder -> Builder
85addParensIf needsParens str =
94addParensIf needsParens str =
86 if needsParens then
95 if needsParens then
87− "(" ++ str ++ ")"
96+ "(" <> str <> ")"
88
97
89 else
98 else
90 str
99 str
@@ -94,7 +103,7 @@ isCons :: Pattern -> Bool
94isCons pattern =
103isCons pattern =
95 case pattern of
104 case pattern of
96 Ctor tag [_,_] ->
105 Ctor tag [_,_] ->
97− Var.toString tag == "::"
106+ Var.toText tag == "::"
98
107
99 _ ->
108 _ ->
100 False
109 False
src/Nitpick/PatternMatches.hs+9−6
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module Nitpick.PatternMatches (patternMatches) where
3module Nitpick.PatternMatches (patternMatches) where
3
4
4{- The algorithm used here comes from "Warnings for Pattern Matching"
5{- The algorithm used here comes from "Warnings for Pattern Matching"
@@ -14,6 +15,8 @@ import qualified Data.List as List
14import qualified Data.Map as Map
15import qualified Data.Map as Map
15import qualified Data.Maybe as Maybe
16import qualified Data.Maybe as Maybe
16import qualified Data.Set as Set
17import qualified Data.Set as Set
18+import qualified Data.Text as Text
19+import Data.Text (Text)
17
20
18import qualified AST.Expression.Canonical as C
21import qualified AST.Expression.Canonical as C
19import qualified AST.Helpers as Help
22import qualified AST.Helpers as Help
@@ -379,7 +382,7 @@ isCompleteHelp ctors row =
379
382
380
383
381type ArityDict =
384type ArityDict =
382− Map.Map Var.Home (Map.Map String ArityInfo)
385+ Map.Map Var.Home (Map.Map Text ArityInfo)
383
386
384
387
385data ArityInfo =
388data ArityInfo =
@@ -416,21 +419,21 @@ builtinDict =
416 ++ map makeTupleInfo [0..8]
419 ++ map makeTupleInfo [0..8]
417
420
418
421
419−makeTupleInfo :: Int -> ( String, ArityInfo )
422+makeTupleInfo :: Int -> ( Text, ArityInfo )
420makeTupleInfo n =
423makeTupleInfo n =
421 let
424 let
422 name =
425 name =
423− "_Tuple" ++ show n
426+ Text.pack ("_Tuple" ++ show n)
424 in
427 in
425 ( name, ArityInfo 1 [ (Var.builtin name, n) ] )
428 ( name, ArityInfo 1 [ (Var.builtin name, n) ] )
426
429
427
430
428−toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map String ArityInfo
431+toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map Text ArityInfo
429toArityEntry name unions =
432toArityEntry name unions =
430 Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
433 Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
431
434
432
435
433−toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo String -> [(String, ArityInfo)]
436+toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo Text -> [(Text, ArityInfo)]
434toArityEntryHelp name (_tvars, ctors) =
437toArityEntryHelp name (_tvars, ctors) =
435 let
438 let
436 arityInfo =
439 arityInfo =
@@ -447,7 +450,7 @@ getArityInfo var@(Var.Canonical home name) arityDict =
447
450
448 Nothing ->
451 Nothing ->
449 if Help.isTuple name then
452 if Help.isTuple name then
450− ArityInfo 1 [ (var, read (drop 6 name)) ]
453+ ArityInfo 1 [ (var, read (drop 6 (Text.unpack name))) ]
451 else
454 else
452 error
455 error
453 "Since the Nitpick phase happens after canonicalization and type\
456 "Since the Nitpick phase happens after canonicalization and type\
src/Nitpick/TopLevelTypes.hs+8−6
@@ -1,9 +1,11 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module Nitpick.TopLevelTypes (topLevelTypes) where
3module Nitpick.TopLevelTypes (topLevelTypes) where
3
4
4import qualified Data.Foldable as F
5import qualified Data.Foldable as F
5import Data.Map ((!))
6import Data.Map ((!))
6import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified Data.Text as Text
7
9
8import qualified AST.Expression.Canonical as Can
10import qualified AST.Expression.Canonical as Can
9import qualified AST.Module.Name as ModuleName
11import qualified AST.Module.Name as ModuleName
@@ -24,7 +26,7 @@ type Result =
24
26
25
27
26type TypeDict =
28type TypeDict =
27− Map.Map String Type.Canonical
29+ Map.Map Var.Canonical Type.Canonical
28
30
29
31
30
32
@@ -62,7 +64,7 @@ checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =
62 (P.Var name, Nothing) ->
64 (P.Var name, Nothing) ->
63 let
65 let
64 warning =
66 warning =
65− Warning.MissingTypeAnnotation name (typeEnv ! name)
67+ Warning.MissingTypeAnnotation (Text.unpack name) (typeEnv ! Var.local name)
66 in
68 in
67 Result.warn region warning ()
69 Result.warn region warning ()
68
70
@@ -78,7 +80,7 @@ checkMain :: TypeDict -> Can.Def -> Result Can.Def
78checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
80checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
79 let
81 let
80 mainType =
82 mainType =
81− typeEnv ! "main"
83+ typeEnv ! Var.local "main"
82
84
83 makeError tipe maybeMsg =
85 makeError tipe maybeMsg =
84 A.A region (Error.BadFlags tipe maybeMsg)
86 A.A region (Error.BadFlags tipe maybeMsg)
@@ -107,19 +109,19 @@ checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
107
109
108program :: Type.Canonical
110program :: Type.Canonical
109program =
111program =
110− Type.Type (Var.inCore ["Platform"] "Program")
112+ Type.Type (Var.inCore "Platform" "Program")
111
113
112
114
113never :: Type.Canonical
115never :: Type.Canonical
114never =
116never =
115− Type.Type (Var.inCore ["Basics"] "Never")
117+ Type.Type (Var.inCore "Basics" "Never")
116
118
117
119
118vdomNode :: Type.Canonical
120vdomNode :: Type.Canonical
119vdomNode =
121vdomNode =
120 let
122 let
121 vdom =
123 vdom =
122− ModuleName.Canonical Pkg.virtualDom ["VirtualDom"]
124+ ModuleName.Canonical Pkg.virtualDom "VirtualDom"
123 in
125 in
124 Type.Type (Var.fromModule vdom "Node")
126 Type.Type (Var.fromModule vdom "Node")
125
127