@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
33module Elm.Outline
44 ( Outline(..)
55 , AppOutline(..)
@@ -16,12 +16,10 @@ module Elm.Outline
1616
1717
1818import Prelude hiding (read)
19−import Control.Monad (filterM, liftM)
20−import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import Data.Foldable (traverse_)
19+import Control.Monad (filterM)
2220import qualified Data.Map as Map
2321import qualified Data.NonEmptyList as NE
24−import qualified Data.Utf8 as Utf8
22+import Foreign.Ptr (minusPtr)
2523import qualified System.Directory as Dir
2624import System.FilePath ((</>))
2725
@@ -33,6 +31,9 @@ import qualified Elm.Version as V
3331import qualified File
3432import qualified Json.Decode as D
3533import qualified Json.Encode as E
34+import Json.Encode ((==>))
35+import qualified Json.String as Json
36+import qualified Parse.Primitives as P
3637import qualified Reporting.Exit as Exit
3738
3839
@@ -59,7 +60,7 @@ data AppOutline =
5960data PkgOutline =
6061 PkgOutline
6162 { _pkg_name :: Pkg.Name
62− , _pkg_summary :: Utf8.String
63+ , _pkg_summary :: Json.String
6364 , _pkg_license :: Licenses.License
6465 , _pkg_version :: V.Version
6566 , _pkg_exposed :: Exposed
@@ -71,16 +72,16 @@ data PkgOutline =
7172
7273data Exposed
7374 = ExposedList [ModuleName.Raw]
74− | ExposedDict [(Utf8.String, [ModuleName.Raw])]
75+ | ExposedDict [(Json.String, [ModuleName.Raw])]
7576
7677
7778
7879-- DEFAULTS
7980
8081
81−defaultSummary :: Utf8.String
82+defaultSummary :: Json.String
8283defaultSummary =
83− "helpful summary of your project, less than 80 characters"
84+ Json.fromChars "helpful summary of your project, less than 80 characters"
8485
8586
8687
@@ -115,8 +116,8 @@ encode outline =
115116 case outline of
116117 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
117118 E.object
118− [ "type" ==> E.string "application"
119− , "source-directories" ==> E.list (E.string . Utf8.fromChars) (NE.toList srcDirs)
119+ [ "type" ==> E.chars "application"
120+ , "source-directories" ==> E.list E.chars (NE.toList srcDirs)
120121 , "elm-version" ==> V.encode elm
121122 , "dependencies" ==>
122123 E.object
@@ -132,7 +133,7 @@ encode outline =
132133
133134 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
134135 E.object
135− [ "type" ==> E.string "package"
136+ [ "type" ==> E.string (Json.fromChars "package")
136137 , "name" ==> Pkg.encode name
137138 , "summary" ==> E.string summary
138139 , "license" ==> Licenses.encode license
@@ -144,11 +145,6 @@ encode outline =
144145 ]
145146
146147
147−(==>) :: a -> b -> (a, b)
148−(==>) a b =
149− (a, b)
150−
151−
152148encodeExposed :: Exposed -> E.Value
153149encodeExposed exposed =
154150 case exposed of
@@ -166,7 +162,7 @@ encodeModule name =
166162
167163encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
168164encodeDeps encodeValue deps =
169− E.dict Pkg.toString encodeValue deps
165+ E.dict Pkg.toJsonString encodeValue deps
170166
171167
172168
@@ -207,16 +203,14 @@ type Decoder a =
207203
208204decoder :: Decoder Outline
209205decoder =
206+ let
207+ application = Json.fromChars "application"
208+ package = Json.fromChars "package"
209+ in
210210 do tipe <- D.field "type" D.string
211− case tipe of
212− "application" ->
213− App <$> appDecoder
214−
215− "package" ->
216− Pkg <$> pkgDecoder
217−
218− other ->
219− D.failure (Exit.OP_BadType other)
211+ if | tipe == application -> App <$> appDecoder
212+ | tipe == package -> Pkg <$> pkgDecoder
213+ | otherwise -> D.failure Exit.OP_BadType
220214
221215
222216appDecoder :: Decoder AppOutline
@@ -233,7 +227,7 @@ appDecoder =
233227pkgDecoder :: Decoder PkgOutline
234228pkgDecoder =
235229 PkgOutline
236− <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)
230+ <$> D.field "name" nameDecoder
237231 <*> D.field "summary" summaryDecoder
238232 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
239233 <*> D.field "version" versionDecoder
@@ -247,17 +241,21 @@ pkgDecoder =
247241-- JSON DECODE HELPERS
248242
249243
250−summaryDecoder :: Decoder Utf8.String
244+nameDecoder :: Decoder Pkg.Name
245+nameDecoder =
246+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
247+
248+
249+summaryDecoder :: Decoder Json.String
251250summaryDecoder =
252− do summary <- D.string
253− if Utf8.size summary < 80
254− then return summary
255− else D.failure Exit.OP_BadSummaryTooLong
251+ D.customString
252+ (boundParser 80 Exit.OP_BadSummaryTooLong)
253+ (\_ _ -> Exit.OP_BadSummaryTooLong)
256254
257255
258256versionDecoder :: Decoder V.Version
259257versionDecoder =
260− D.mapError Exit.OP_BadVersion V.decoder
258+ D.mapError (uncurry Exit.OP_BadVersion) V.decoder
261259
262260
263261constraintDecoder :: Decoder Con.Constraint
@@ -267,27 +265,12 @@ constraintDecoder =
267265
268266depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
269267depsDecoder 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
283269
284270
285271dirsDecoder :: Decoder (NE.List FilePath)
286272dirsDecoder =
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
291274
292275
293276
@@ -298,81 +281,33 @@ exposedDecoder :: Decoder Exposed
298281exposedDecoder =
299282 D.oneOf
300283 [ ExposedList <$> D.list moduleDecoder
301− , do pairs <- D.pairs (D.list moduleDecoder)
302− traverse_ (checkHeader . fst) pairs
303− return (ExposedDict pairs)
284+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
304285 ]
305286
306287
307288moduleDecoder :: Decoder ModuleName.Raw
308289moduleDecoder =
309− D.mapError 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
290+ D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
340291
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)
349292
293+headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
294+headerKeyDecoder =
295+ D.KeyDecoder
296+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
297+ (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
350298
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
354299
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)
365300
301+-- BOUND PARSER
366302
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
372303
373− get =
374− do n <- getWord8
375− case n of
376− 0 -> liftM ExposedList get
377− 1 -> liftM ExposedDict get
378− _ -> error "binary encoding of ProjectDeps was corrupted"
304+boundParser :: Int -> x -> P.Parser x Json.String
305+boundParser bound tooLong =
306+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
307+ let
308+ len = minusPtr end pos
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)