git.iko.soy/elk
on master help sign in
use new parsers for elm.json / remove binary instance
82b3bd0Evan Czaplicki
builder/src/Elm/Outline.hs+52−117
compare with master
unifiedsplit
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
3module Elm.Outline
3module Elm.Outline
4 ( Outline(..)
4 ( Outline(..)
5 , AppOutline(..)
5 , AppOutline(..)
@@ -16,12 +16,10 @@ module Elm.Outline
16
16
17
17
18import Prelude hiding (read)
18import Prelude hiding (read)
19−import Control.Monad (filterM, liftM)
19+import Control.Monad (filterM)
20−import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import Data.Foldable (traverse_)
22import qualified Data.Map as Map
20import qualified Data.Map as Map
23import qualified Data.NonEmptyList as NE
21import qualified Data.NonEmptyList as NE
24−import qualified Data.Utf8 as Utf8
22+import Foreign.Ptr (minusPtr)
25import qualified System.Directory as Dir
23import qualified System.Directory as Dir
26import System.FilePath ((</>))
24import System.FilePath ((</>))
27
25
@@ -33,6 +31,9 @@ import qualified Elm.Version as V
33import qualified File
31import qualified File
34import qualified Json.Decode as D
32import qualified Json.Decode as D
35import qualified Json.Encode as E
33import qualified Json.Encode as E
34+import Json.Encode ((==>))
35+import qualified Json.String as Json
36+import qualified Parse.Primitives as P
36import qualified Reporting.Exit as Exit
37import qualified Reporting.Exit as Exit
37
38
38
39
@@ -59,7 +60,7 @@ data AppOutline =
59data PkgOutline =
60data PkgOutline =
60 PkgOutline
61 PkgOutline
61 { _pkg_name :: Pkg.Name
62 { _pkg_name :: Pkg.Name
62− , _pkg_summary :: Utf8.String
63+ , _pkg_summary :: Json.String
63 , _pkg_license :: Licenses.License
64 , _pkg_license :: Licenses.License
64 , _pkg_version :: V.Version
65 , _pkg_version :: V.Version
65 , _pkg_exposed :: Exposed
66 , _pkg_exposed :: Exposed
@@ -71,16 +72,16 @@ data PkgOutline =
71
72
72data Exposed
73data Exposed
73 = ExposedList [ModuleName.Raw]
74 = ExposedList [ModuleName.Raw]
74− | ExposedDict [(Utf8.String, [ModuleName.Raw])]
75+ | ExposedDict [(Json.String, [ModuleName.Raw])]
75
76
76
77
77
78
78-- DEFAULTS
79-- DEFAULTS
79
80
80
81
81−defaultSummary :: Utf8.String
82+defaultSummary :: Json.String
82defaultSummary =
83defaultSummary =
83− "helpful summary of your project, less than 80 characters"
84+ Json.fromChars "helpful summary of your project, less than 80 characters"
84
85
85
86
86
87
@@ -115,8 +116,8 @@ encode outline =
115 case outline of
116 case outline of
116 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
117 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
117 E.object
118 E.object
118− [ "type" ==> E.string "application"
119+ [ "type" ==> E.chars "application"
119− , "source-directories" ==> E.list (E.string . Utf8.fromChars) (NE.toList srcDirs)
120+ , "source-directories" ==> E.list E.chars (NE.toList srcDirs)
120 , "elm-version" ==> V.encode elm
121 , "elm-version" ==> V.encode elm
121 , "dependencies" ==>
122 , "dependencies" ==>
122 E.object
123 E.object
@@ -132,7 +133,7 @@ encode outline =
132
133
133 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
134 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
134 E.object
135 E.object
135− [ "type" ==> E.string "package"
136+ [ "type" ==> E.string (Json.fromChars "package")
136 , "name" ==> Pkg.encode name
137 , "name" ==> Pkg.encode name
137 , "summary" ==> E.string summary
138 , "summary" ==> E.string summary
138 , "license" ==> Licenses.encode license
139 , "license" ==> Licenses.encode license
@@ -144,11 +145,6 @@ encode outline =
144 ]
145 ]
145
146
146
147
147−(==>) :: a -> b -> (a, b)
148−(==>) a b =
149− (a, b)
150−
151−
152encodeExposed :: Exposed -> E.Value
148encodeExposed :: Exposed -> E.Value
153encodeExposed exposed =
149encodeExposed exposed =
154 case exposed of
150 case exposed of
@@ -166,7 +162,7 @@ encodeModule name =
166
162
167encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
163encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
168encodeDeps encodeValue deps =
164encodeDeps encodeValue deps =
169− E.dict Pkg.toString encodeValue deps
165+ E.dict Pkg.toJsonString encodeValue deps
170
166
171
167
172
168
@@ -207,16 +203,14 @@ type Decoder a =
207
203
208decoder :: Decoder Outline
204decoder :: Decoder Outline
209decoder =
205decoder =
206+ let
207+ application = Json.fromChars "application"
208+ package = Json.fromChars "package"
209+ in
210 do tipe <- D.field "type" D.string
210 do tipe <- D.field "type" D.string
211− case tipe of
212− "application" ->
213− App <$> appDecoder
211+ if | tipe == application -> App <$> appDecoder
214−
215− "package" ->
216− Pkg <$> pkgDecoder
212+ | tipe == package -> Pkg <$> pkgDecoder
217−
218− other ->
219− D.failure (Exit.OP_BadType other)
213+ | otherwise -> D.failure Exit.OP_BadType
220
214
221
215
222appDecoder :: Decoder AppOutline
216appDecoder :: Decoder AppOutline
@@ -233,7 +227,7 @@ appDecoder =
233pkgDecoder :: Decoder PkgOutline
227pkgDecoder :: Decoder PkgOutline
234pkgDecoder =
228pkgDecoder =
235 PkgOutline
229 PkgOutline
236− <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)
230+ <$> D.field "name" nameDecoder
237 <*> D.field "summary" summaryDecoder
231 <*> D.field "summary" summaryDecoder
238 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
232 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
239 <*> D.field "version" versionDecoder
233 <*> D.field "version" versionDecoder
@@ -247,17 +241,21 @@ pkgDecoder =
247-- JSON DECODE HELPERS
241-- JSON DECODE HELPERS
248
242
249
243
244+nameDecoder :: Decoder Pkg.Name
245+nameDecoder =
246+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
247+
248+
250−summaryDecoder :: Decoder Utf8.String
249+summaryDecoder :: Decoder Json.String
251summaryDecoder =
250summaryDecoder =
252− do summary <- D.string
251+ D.customString
253− if Utf8.size summary < 80
252+ (boundParser 80 Exit.OP_BadSummaryTooLong)
254− then return summary
255− else D.failure Exit.OP_BadSummaryTooLong
253+ (\_ _ -> Exit.OP_BadSummaryTooLong)
256
254
257
255
258versionDecoder :: Decoder V.Version
256versionDecoder :: Decoder V.Version
259versionDecoder =
257versionDecoder =
260− D.mapError Exit.OP_BadVersion V.decoder
258+ D.mapError (uncurry Exit.OP_BadVersion) V.decoder
261
259
262
260
263constraintDecoder :: Decoder Con.Constraint
261constraintDecoder :: Decoder Con.Constraint
@@ -267,27 +265,12 @@ constraintDecoder =
267
265
268depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
266depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
269depsDecoder valueDecoder =
267depsDecoder valueDecoder =
270− Map.fromList <$> (
271− traverse validateKey =<< D.pairs valueDecoder
272− )
273−
274−
275−validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
276−validateKey (key, value) =
277− case Pkg.fromString key of
278− Right name ->
279− return (name, value)
280−
281− Left _ ->
282− D.failure (Exit.OP_BadDependencyName key)
268+ D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
283
269
284
270
285dirsDecoder :: Decoder (NE.List FilePath)
271dirsDecoder :: Decoder (NE.List FilePath)
286dirsDecoder =
272dirsDecoder =
287− do dirs <- D.list D.string
288− case map Utf8.toChars dirs of
289− d:ds -> return (NE.List d ds)
290− [] -> D.failure Exit.OP_NoSrcDirs
273+ fmap Json.toChars <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
291
274
292
275
293
276
@@ -298,81 +281,33 @@ exposedDecoder :: Decoder Exposed
298exposedDecoder =
281exposedDecoder =
299 D.oneOf
282 D.oneOf
300 [ ExposedList <$> D.list moduleDecoder
283 [ ExposedList <$> D.list moduleDecoder
301− , do pairs <- D.pairs (D.list moduleDecoder)
284+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
302− traverse_ (checkHeader . fst) pairs
303− return (ExposedDict pairs)
304 ]
285 ]
305
286
306
287
307moduleDecoder :: Decoder ModuleName.Raw
288moduleDecoder :: Decoder ModuleName.Raw
308moduleDecoder =
289moduleDecoder =
309− D.mapError Exit.OP_BadModuleName ModuleName.decoder
290+ D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
310−
311−
312−checkHeader :: Utf8.String -> Decoder ()
313−checkHeader header =
314− if Utf8.size header < 20
315− then return ()
316− else D.failure (Exit.OP_BadModuleHeaderTooLong header)
317−
318−
319−
320−-- BINARY
321−
322−
323−instance Binary Outline where
324− put outline =
325− case outline of
326− App a -> putWord8 0 >> put a
327− Pkg a -> putWord8 1 >> put a
328−
329− get =
330− do n <- getWord8
331− case n of
332− 0 -> liftM App get
333− 1 -> liftM Pkg get
334− _ -> error "binary encoding of Outline was corrupted"
335−
336−
337−instance Binary AppOutline where
338− put (AppOutline a b c d e f) =
339− put a >> put b >> put c >> put d >> put e >> put f
340
291
341− get =
342− do a <- get
343− b <- get
344− c <- get
345− d <- get
346− e <- get
347− f <- get
348− return (AppOutline a b c d e f)
349
292
293+headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
294+headerKeyDecoder =
295+ D.KeyDecoder
296+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
297+ (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
350
298
351−instance Binary PkgOutline where
352− put (PkgOutline a b c d e f g h) =
353− put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
354
299
355− get =
356− do a <- get
357− b <- get
358− c <- get
359− d <- get
360− e <- get
361− f <- get
362− g <- get
363− h <- get
364− return (PkgOutline a b c d e f g h)
365
300
301+-- BOUND PARSER
366
302
367−instance Binary Exposed where
368− put exposed =
369− case exposed of
370− ExposedList a -> putWord8 0 >> put a
371− ExposedDict a -> putWord8 1 >> put a
372
303
373− get =
304+boundParser :: Int -> x -> P.Parser x Json.String
374− do n <- getWord8
305+boundParser bound tooLong =
375− case n of
306+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
376− 0 -> liftM ExposedList get
307+ let
377− 1 -> liftM ExposedDict get
308+ len = minusPtr end pos
378− _ -> error "binary encoding of ProjectDeps was corrupted"
309+ newCol = col + fromIntegral len
310+ in
311+ if len < bound
312+ then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
313+ else cerr row newCol (\_ _ -> tooLong)