git.iko.soy/elk
on master help sign in
Start moving to monorepo. Move evancz/cli in.
309cb25Evan Czaplicki
cli/elm.cabalnew file+92
compare with master
unifiedsplit
@@ -0,0 +1,92 @@
1+Name: elm
2+Version: 0.19.0
3+
4+Synopsis:
5+ Executable for all Elm command line stuff
6+Description:
7+ Work with the REPL, reactor, make, install, etc.
8+
9+Homepage:
10+ http://github.com/evancz/cli
11+
12+License: BSD3
13+License-file: LICENSE
14+
15+Author: Evan Czaplicki
16+Maintainer: info@elm-lang.org
17+Copyright: Copyright: (c) 2012-present Evan Czaplicki
18+
19+Category: Language
20+
21+Build-type: Simple
22+Cabal-version: >=1.9
23+
24+source-repository head
25+ type: git
26+ location: git://github.com/evancz/cli.git
27+
28+Executable elm
29+
30+ ghc-options:
31+ -threaded -O2 -Wall -Werror
32+
33+ hs-source-dirs:
34+ src
35+
36+ other-extensions:
37+ TemplateHaskell
38+
39+ Main-is:
40+ Main.hs
41+
42+ other-modules:
43+ Bump
44+ CommandLine.Args
45+ CommandLine.Args.Internal
46+ Develop
47+ Develop.Compile
48+ Develop.Generate.Help
49+ Develop.Generate.Index
50+ Develop.Generate.NotFound
51+ Develop.StaticFiles
52+ Develop.StaticFiles.Build
53+ Diff
54+ Install
55+ Make
56+ Publish
57+ Repl
58+
59+ Build-depends:
60+ ansi-wl-pprint >= 0.6.7.3,
61+ base >=4.2 && <5,
62+ binary,
63+ blaze-html,
64+ bytestring >= 0.9 && < 0.11,
65+ bytestring-trie,
66+ containers >= 0.3 && < 0.6,
67+ directory >= 1.0 && < 2.0,
68+ edit-distance,
69+ elm-compiler == 0.19.0,
70+ builder,
71+ file-embed,
72+ filepath >= 1 && < 2.0,
73+ haskeline,
74+ HTTP >= 4000.2.5 && < 4000.4,
75+ http-client,
76+ http-client-tls,
77+ http-types,
78+ mtl >= 2.2.1 && < 3,
79+ network >= 2.4 && < 2.7,
80+ parallel-io,
81+ process >= 1.5,
82+ snap-core,
83+ snap-server,
84+ template-haskell,
85+ text,
86+ time,
87+ unordered-containers,
88+ utf8-string,
89+ vector,
90+ websockets,
91+ websockets-snap,
92+ zip-archive
cli/src/Bump.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Bump (run) where
3+
4+
5+import Control.Monad (void)
6+
7+import qualified Elm.Bump as Bump
8+import qualified Elm.Project as Project
9+import qualified Reporting.Task as Task
10+import qualified Reporting.Progress.Terminal as Terminal
11+
12+
13+
14+-- RUN
15+
16+
17+run :: IO ()
18+run =
19+ do reporter <- Terminal.create
20+ void $ Task.run reporter $
21+ do summary <- Project.getRoot
22+ Bump.bump summary
cli/src/CommandLine/Args.hsnew file+163
@@ -0,0 +1,163 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module CommandLine.Args
3+ ( chomp
4+ , ElmRoute(..)
5+ , DevFlags(..)
6+ , MakeFlags(..)
7+ , ReplFlags(..)
8+ )
9+ where
10+
11+
12+import CommandLine.Args.Internal as Args
13+import qualified Data.Text as Text
14+import qualified Elm.Diff as Diff
15+import qualified Elm.Package as Pkg
16+import qualified Elm.Project.Flags as Flags
17+import qualified System.FilePath as FP
18+
19+
20+
21+-- ROUTE
22+
23+
24+data ElmRoute
25+ = Naked () ()
26+ | Version () ()
27+ | Install Pkg.Name ()
28+ | Publish () ()
29+ | Make [FilePath] MakeFlags
30+ | Bump () ()
31+ | Diff Diff.Args ()
32+ | Repl () ReplFlags
33+ | Dev () DevFlags
34+
35+
36+chomp :: IO ElmRoute
37+chomp =
38+ get
39+ (Route Naked noArgs noFlags)
40+ [ "version" ==> Route Version noArgs noFlags
41+ , "install" ==> Route Install (required package) noFlags
42+ , "publish" ==> Route Publish noArgs noFlags
43+ , "make" ==> Route Make (zeroOrMore file) makeFlags
44+ , "bump" ==> Route Bump noArgs noFlags
45+ , "diff" ==> Route Diff diffArgs noFlags
46+ , "repl" ==> Route Repl noArgs replFlags
47+ , "develop" ==> Route Dev noArgs devFlags
48+ ]
49+
50+
51+(==>) :: a -> b -> (a, b)
52+(==>) =
53+ (,)
54+
55+
56+
57+-- MAKE
58+
59+
60+data MakeFlags =
61+ MakeFlags
62+ { _warn :: Bool
63+ , _debug :: Bool
64+ , _output :: Maybe Flags.Output
65+ , _server :: Bool
66+ }
67+
68+
69+makeFlags :: Flags MakeFlags
70+makeFlags =
71+ flags MakeFlags
72+ |-- onOff "warn" "Report warnings to improve code quality."
73+ |-- onOff "debug" "Generate programs in debug mode."
74+ |-- flag "output" output "Specify the name of the resulting JS file (use --output=/dev/null for no output)"
75+ |-- onOff "server" "Generate JS for server-side rendering."
76+
77+
78+output :: Parser Flags.Output
79+output =
80+ custom "PATH" $ \string ->
81+ if string == "/dev/null" then
82+ Just Flags.None
83+
84+ else
85+ case FP.splitPath string of
86+ [] ->
87+ Nothing
88+
89+ [name] ->
90+ outputCustom Nothing name
91+
92+ segments ->
93+ outputCustom (Just (FP.joinPath (init segments))) (last segments)
94+
95+
96+outputCustom :: Maybe FilePath -> FilePath -> Maybe Flags.Output
97+outputCustom maybeDir fileName =
98+ if FP.takeExtension fileName == ".js" then
99+ Just (Flags.Custom maybeDir fileName)
100+ else
101+ Nothing
102+
103+
104+
105+-- REPL
106+
107+
108+data ReplFlags =
109+ ReplFlags
110+ { _interpreter :: Maybe FilePath
111+ }
112+
113+
114+replFlags :: Flags ReplFlags
115+replFlags =
116+ flags ReplFlags
117+ |-- flag "interpreter" (anything "EXE") "Path to a alternate JS interpreter, like node or nodejs."
118+
119+
120+
121+-- DEVELOP
122+
123+
124+data DevFlags =
125+ DevFlags
126+ { _port :: Maybe Int
127+ }
128+
129+
130+devFlags :: Flags DevFlags
131+devFlags =
132+ flags DevFlags
133+ |-- flag "port" (int "PORT") "The port of the server (default: 8000)"
134+
135+
136+
137+-- DIFF
138+
139+
140+diffArgs :: Args Diff.Args
141+diffArgs =
142+ oneOf
143+ [ require0 Diff.CodeVsLatest
144+ , require1 Diff.CodeVsExactly version
145+ , require2 Diff.LocalInquiry version version
146+ , require3 Diff.GlobalInquiry package version version
147+ ]
148+
149+
150+package :: Parser Pkg.Name
151+package =
152+ custom "USER/PROJECT" $ \string ->
153+ case Pkg.fromText (Text.pack string) of
154+ Left _ ->
155+ Nothing
156+
157+ Right a ->
158+ Just a
159+
160+
161+version :: Parser Pkg.Version
162+version =
163+ custom "VERSION" (Pkg.versionFromText . Text.pack)
cli/src/CommandLine/Args/Internal.hsnew file+851
@@ -0,0 +1,851 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE GADTs #-}
3+module CommandLine.Args.Internal
4+ ( get
5+ , Flags, noFlags, flags, (|--)
6+ , Flag, flag, onOff
7+ , Parser, int, file, anything, custom
8+ , Args, noArgs, required, optional, zeroOrMore, oneOrMore, oneOf
9+ , require0, require1, require2, require3, require4, require5
10+ , RequiredArgs, args, exactly, (!), (?), (...)
11+ , Route(..)
12+ )
13+ where
14+
15+import qualified Data.Char as Char
16+import qualified Data.List as List
17+import GHC.IO.Handle (hIsTerminalDevice)
18+import System.Environment (getArgs)
19+import System.Exit (exitFailure)
20+import System.IO (hPutStrLn, stderr)
21+import Text.PrettyPrint.ANSI.Leijen
22+ ( Doc, (<>), comma, displayIO, fillSep, green
23+ , plain, red, renderPretty, text, vcat
24+ )
25+
26+import Elm.Utils (nearbyNames)
27+
28+
29+
30+-- ROUTE
31+
32+
33+data Route a where
34+ Route :: (args -> flags -> a) -> Args args -> Flags flags -> Route a
35+
36+
37+
38+-- FLAGS
39+
40+
41+data Flags a where
42+ FDone :: a -> Flags a
43+ FMore :: Flags (a -> b) -> Flag a -> Flags b
44+
45+
46+noFlags :: Flags ()
47+noFlags =
48+ FDone ()
49+
50+
51+flags :: a -> Flags a
52+flags =
53+ FDone
54+
55+
56+(|--) :: Flags (a -> b) -> Flag a -> Flags b
57+(|--) =
58+ FMore
59+
60+
61+
62+-- FLAG
63+
64+
65+data Flag a where
66+ Flag :: String -> Parser a -> String -> Flag (Maybe a)
67+ OnOff :: String -> String -> Flag Bool
68+
69+
70+flag :: String -> Parser a -> String -> Flag (Maybe a)
71+flag =
72+ Flag
73+
74+
75+onOff :: String -> String -> Flag Bool
76+onOff =
77+ OnOff
78+
79+
80+
81+-- PARSERS
82+
83+
84+data Parser a where
85+ Anything :: String -> Parser String
86+ File :: Parser FilePath
87+ Int :: String -> Parser Int
88+ Custom :: String -> (String -> Maybe a) -> Parser a
89+
90+
91+file :: Parser FilePath
92+file =
93+ File
94+
95+
96+int :: String -> Parser Int
97+int =
98+ Int
99+
100+
101+anything :: String -> Parser String
102+anything =
103+ Anything
104+
105+
106+custom :: String -> (String -> Maybe a) -> Parser a
107+custom =
108+ Custom
109+
110+
111+data ParserInfo =
112+ ParserInfo
113+ { _type :: String
114+ }
115+
116+
117+getParserInfo :: Parser a -> ParserInfo
118+getParserInfo parser =
119+ case parser of
120+ Anything tipe ->
121+ ParserInfo tipe
122+
123+ File ->
124+ ParserInfo "FILE"
125+
126+ Int tipe ->
127+ ParserInfo tipe
128+
129+ Custom tipe _ ->
130+ ParserInfo tipe
131+
132+
133+runParser :: Parser a -> String -> Either ParserError a
134+runParser parser str =
135+ case parser of
136+ Anything _ ->
137+ Right str
138+
139+ File ->
140+ Right str
141+
142+ Int tipe ->
143+ if all Char.isDigit str then
144+ Right (read str :: Int)
145+ else
146+ Left (Expecting tipe)
147+
148+ Custom tipe toMaybe ->
149+ case toMaybe str of
150+ Nothing ->
151+ Left (Expecting tipe)
152+
153+ Just a ->
154+ Right a
155+
156+
157+data ParserError = Expecting String
158+
159+
160+
161+-- ARGS
162+
163+
164+noArgs :: Args ()
165+noArgs =
166+ exactly (args ())
167+
168+
169+required :: Parser a -> Args a
170+required parser =
171+ require1 id parser
172+
173+
174+optional :: Parser a -> Args (Maybe a)
175+optional parser =
176+ args id
177+ ? parser
178+
179+
180+zeroOrMore :: Parser a -> Args [a]
181+zeroOrMore parser =
182+ args id
183+ ... parser
184+
185+
186+oneOrMore :: Parser a -> Args (a, [a])
187+oneOrMore parser =
188+ args (,)
189+ ! parser
190+ ... parser
191+
192+
193+require0 :: args -> Args args
194+require0 value =
195+ exactly (args value)
196+
197+
198+require1 :: (a -> args) -> Parser a -> Args args
199+require1 func a =
200+ exactly (
201+ args func
202+ ! a
203+ )
204+
205+
206+require2 :: (a -> b -> args) -> Parser a -> Parser b -> Args args
207+require2 func a b =
208+ exactly (
209+ args func
210+ ! a
211+ ! b
212+ )
213+
214+
215+require3 :: (a -> b -> c -> args) -> Parser a -> Parser b -> Parser c -> Args args
216+require3 func a b c =
217+ exactly (
218+ args func
219+ ! a
220+ ! b
221+ ! c
222+ )
223+
224+
225+require4 :: (a -> b -> c -> d -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Args args
226+require4 func a b c d =
227+ exactly (
228+ args func
229+ ! a
230+ ! b
231+ ! c
232+ ! d
233+ )
234+
235+
236+require5 :: (a -> b -> c -> d -> e -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Args args
237+require5 func a b c d e =
238+ exactly (
239+ args func
240+ ! a
241+ ! b
242+ ! c
243+ ! d
244+ ! e
245+ )
246+
247+
248+oneOf :: [Args a] -> Args a
249+oneOf =
250+ OneOf
251+
252+
253+
254+-- FANCE ARGS
255+
256+
257+data RequiredArgs a where
258+ Done :: a -> RequiredArgs a
259+ Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
260+
261+
262+data Args a where
263+ Exactly :: RequiredArgs a -> Args a
264+ Optional :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b
265+ Multiple :: RequiredArgs ([a] -> b) -> Parser a -> Args b
266+ OneOf :: [Args a] -> Args a
267+
268+
269+args :: a -> RequiredArgs a
270+args =
271+ Done
272+
273+
274+exactly :: RequiredArgs a -> Args a
275+exactly =
276+ Exactly
277+
278+
279+(!) :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
280+(!) =
281+ Required
282+
283+
284+(?) :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b
285+(?) =
286+ Optional
287+
288+
289+(...) :: RequiredArgs ([a] -> b) -> Parser a -> Args b
290+(...) =
291+ Multiple
292+
293+
294+
295+-- GET
296+
297+
298+get :: Route a -> [(String, Route a)] -> IO a
299+get route namedRoutes =
300+ do chunks <- getArgs
301+ case parse route namedRoutes chunks of
302+ Right flagsAndArgs ->
303+ return flagsAndArgs
304+
305+ Left err ->
306+ failure err
307+
308+
309+
310+-- PARSE
311+
312+
313+data Error
314+ = AfterCommand String RouteError
315+ | BadCommand String [String] String
316+ | NoCommand RouteError
317+
318+
319+parse :: Route a -> [(String, Route a)] -> [String] -> Either Error a
320+parse route namedRoutes chunks =
321+ case parseHelp namedRoutes chunks [] of
322+ Right answer ->
323+ Right answer
324+
325+ Left errors ->
326+ case parseRoute route chunks of
327+ Right answer ->
328+ Right answer
329+
330+ Left routeError ->
331+ case errors of
332+ (name, specificRouteError) : _ ->
333+ Left (AfterCommand name specificRouteError)
334+
335+ [] ->
336+ case chunks of
337+ first : _ | not (List.isPrefixOf "-" first) ->
338+ case nearbyNames id first (map fst namedRoutes) of
339+ [] ->
340+ Left (NoCommand routeError)
341+
342+ suggestions ->
343+ Left (BadCommand first (init suggestions) (last suggestions))
344+
345+ _ ->
346+ Left (NoCommand routeError)
347+
348+
349+parseHelp :: [(String, Route a)] -> [String] -> RouteErrors -> Either RouteErrors a
350+parseHelp namedRoutes chunks errors =
351+ case namedRoutes of
352+ [] ->
353+ Left errors
354+
355+ (name, route) : rest ->
356+ case parseNamedRoute name route chunks of
357+ Left errs ->
358+ parseHelp rest chunks (errs ++ errors)
359+
360+ Right answer ->
361+ Right answer
362+
363+
364+
365+-- PARSE NAMED ROUTE
366+
367+
368+type RouteErrors = [(String, RouteError)]
369+
370+
371+parseNamedRoute :: String -> Route a -> [String] -> Either RouteErrors a
372+parseNamedRoute name route rawChunks =
373+ case rawChunks of
374+ first : chunks | name == first ->
375+ case parseRoute route chunks of
376+ Right answer ->
377+ Right answer
378+
379+ Left err ->
380+ Left [(name, err)]
381+
382+ _ ->
383+ Left []
384+
385+
386+
387+-- PARSE ROUTE
388+
389+
390+data RouteError = BadFlags FlagError | BadArgs ArgError
391+
392+
393+parseRoute :: Route a -> [String] -> Either RouteError a
394+parseRoute (Route func args_ flags_) chunks =
395+ case parseFlags flags_ chunks of
396+ Left flagError ->
397+ Left (BadFlags flagError)
398+
399+ Right (flagData, remainingChunks) ->
400+ case parseArgs args_ remainingChunks of
401+ Left argError ->
402+ Left (BadArgs argError)
403+
404+ Right argData ->
405+ Right (func argData flagData)
406+
407+
408+
409+-- PARSE ARGS
410+
411+
412+data ArgError
413+ = NoneOf [ArgError]
414+ | MissingArg ParserInfo
415+ | BadArg String ParserError
416+ | ExtraArgs [String]
417+
418+
419+parseArgs :: Args a -> [String] -> Either ArgError a
420+parseArgs args_ chunks =
421+ case args_ of
422+ OneOf argsList ->
423+ parseOneOf argsList chunks []
424+
425+ Exactly requiredArgs ->
426+ do (value, extras) <- parseRequiredArgs requiredArgs chunks
427+ case extras of
428+ [] ->
429+ Right value
430+
431+ _ : _ ->
432+ Left (ExtraArgs extras)
433+
434+ Optional requiredArgs optionalParser ->
435+ do (func, subChunks) <- parseRequiredArgs requiredArgs chunks
436+ case subChunks of
437+ [] ->
438+ Right (func Nothing)
439+
440+ [chunk] ->
441+ do value <- runArgParser optionalParser chunk
442+ Right (func (Just value))
443+
444+ _ : extras ->
445+ Left (ExtraArgs extras)
446+
447+ Multiple requiredArgs multiParser ->
448+ do (func, extras) <- parseRequiredArgs requiredArgs chunks
449+ values <- traverse (runArgParser multiParser) extras
450+ Right (func values)
451+
452+
453+parseOneOf :: [Args a] -> [String] -> [ArgError] -> Either ArgError a
454+parseOneOf argsList chunks errors =
455+ case argsList of
456+ [] ->
457+ Left (NoneOf (reverse errors))
458+
459+ args_ : rest ->
460+ case parseArgs args_ chunks of
461+ Left err ->
462+ parseOneOf rest chunks (err:errors)
463+
464+ Right answer ->
465+ Right answer
466+
467+
468+parseRequiredArgs :: RequiredArgs a -> [String] -> Either ArgError (a, [String])
469+parseRequiredArgs args_ chunks =
470+ case args_ of
471+ Done value ->
472+ Right (value, chunks)
473+
474+ Required funcArgs parser ->
475+ do (func, subChunks) <- parseRequiredArgs funcArgs chunks
476+ case subChunks of
477+ [] ->
478+ Left (MissingArg (getParserInfo parser))
479+
480+ chunk : rest ->
481+ do value <- runArgParser parser chunk
482+ Right ( func value, rest )
483+
484+
485+runArgParser :: Parser a -> String -> Either ArgError a
486+runArgParser parser chunk =
487+ case runParser parser chunk of
488+ Left parserError ->
489+ Left (BadArg chunk parserError)
490+
491+ Right value ->
492+ Right value
493+
494+
495+
496+-- PARSE FLAGS
497+
498+
499+type Result a =
500+ Either FlagError (a, [String])
501+
502+
503+data FlagError
504+ = BadOnOff String String
505+ | BadFlag String ParserInfo (Maybe (String, ParserError))
506+ | Unrecognized String [(String, String)]
507+
508+
509+parseFlags :: Flags a -> [String] -> Result a
510+parseFlags flags_ chunks =
511+ do (a, leftoverChunks) <- parseFlagsHelp flags_ chunks
512+ case List.find (List.isPrefixOf "-") leftoverChunks of
513+ Nothing ->
514+ Right (a, leftoverChunks)
515+
516+ Just badArg ->
517+ Left (Unrecognized badArg (collectFlagInfo flags_))
518+
519+
520+parseFlagsHelp :: Flags a -> [String] -> Result a
521+parseFlagsHelp flags_ chunks =
522+ case flags_ of
523+ FDone value ->
524+ Right (value, chunks)
525+
526+ FMore makeFunc flag_ ->
527+ do (func, remainingChunks) <- parseFlagsHelp makeFunc chunks
528+ (arg, leftoverChunks) <- parseFlag flag_ remainingChunks
529+ Right (func arg, leftoverChunks)
530+
531+
532+parseFlag :: Flag a -> [String] -> Result a
533+parseFlag flag_ chunks =
534+ case flag_ of
535+ Flag name parser _summary ->
536+ parseFlagFlag name parser chunks
537+
538+ OnOff name _summary ->
539+ parseFlagOnOff name chunks
540+
541+
542+parseFlagFlag :: String -> Parser a -> [String] -> Result (Maybe a)
543+parseFlagFlag name parser chunks =
544+ case findDoubleDash [] ("--" ++ name) chunks of
545+ Nothing ->
546+ Right (Nothing, chunks)
547+
548+ Just (ChunkZipper before value after) ->
549+ case value of
550+ Definitely str ->
551+ parseFlagFlagHelp name parser before str after
552+
553+ Possibly str ->
554+ parseFlagFlagHelp name parser before str after
555+
556+ DefNope ->
557+ Left (BadFlag name (getParserInfo parser) Nothing)
558+
559+
560+parseFlagFlagHelp :: String -> Parser a -> [String] -> String -> [String] -> Result (Maybe a)
561+parseFlagFlagHelp name parser before str after =
562+ case runParser parser str of
563+ Right value ->
564+ Right (Just value, before ++ after)
565+
566+ Left parserError ->
567+ Left $ BadFlag name (getParserInfo parser) $
568+ Just (str, parserError)
569+
570+
571+parseFlagOnOff :: String -> [String] -> Result Bool
572+parseFlagOnOff name chunks =
573+ case findDoubleDash [] ("--" ++ name) chunks of
574+ Nothing ->
575+ Right (False, chunks)
576+
577+ Just (ChunkZipper before value after) ->
578+ case value of
579+ DefNope ->
580+ Right (True, before ++ after)
581+
582+ Possibly str ->
583+ Right (True, before ++ str : after)
584+
585+ Definitely str ->
586+ Left (BadOnOff name str)
587+
588+
589+
590+-- DOUBLE DASH
591+
592+
593+data ChunkZipper =
594+ ChunkZipper
595+ { _before :: [String]
596+ , _value :: Value
597+ , _after :: [String]
598+ }
599+
600+
601+data Value
602+ = Definitely String
603+ | Possibly String
604+ | DefNope
605+
606+
607+findDoubleDash :: [String] -> String -> [String] -> Maybe ChunkZipper
608+findDoubleDash revPrev prefix chunks =
609+ case chunks of
610+ flag_ : val : rest | flag_ == prefix ->
611+ if List.isPrefixOf "-" val then
612+ Just $ ChunkZipper (reverse revPrev) DefNope (val : rest)
613+ else
614+ Just $ ChunkZipper (reverse revPrev) (Possibly val) rest
615+
616+ [flag_] | flag_ == prefix ->
617+ Just $ ChunkZipper (reverse revPrev) DefNope []
618+
619+ flag_ : rest | List.isPrefixOf (prefix ++ "=") flag_ ->
620+ let
621+ value =
622+ drop (length prefix + 1) flag_
623+ in
624+ Just $ ChunkZipper (reverse revPrev) (Definitely value) rest
625+
626+ chunk : rest ->
627+ findDoubleDash (chunk : revPrev) prefix rest
628+
629+ [] ->
630+ Nothing
631+
632+
633+
634+-- COLLECT FLAG NAMES
635+
636+
637+collectFlagInfo :: Flags a -> [(String, String)]
638+collectFlagInfo flags_ =
639+ collectFlagInfoHelp flags_ []
640+
641+
642+collectFlagInfoHelp :: Flags a -> [(String, String)] -> [(String, String)]
643+collectFlagInfoHelp flags_ info =
644+ case flags_ of
645+ FDone _ ->
646+ reverse info
647+
648+ FMore otherFlags flag_ ->
649+ collectFlagInfoHelp otherFlags (getFlagInfo flag_ : info)
650+
651+
652+getFlagInfo :: Flag a -> (String, String)
653+getFlagInfo flag_ =
654+ case flag_ of
655+ OnOff name summary ->
656+ (name, summary)
657+
658+ Flag name _ summary ->
659+ (name, summary)
660+
661+
662+
663+-- FAILURE
664+
665+
666+failure :: Error -> IO a
667+failure err =
668+ do let doc = toDoc err
669+ isTerminal <- hIsTerminalDevice stderr
670+ displayIO stderr $ renderPretty 1 80 $
671+ if isTerminal then doc else plain doc
672+ hPutStrLn stderr ""
673+ exitFailure
674+
675+
676+toDoc :: Error -> Doc
677+toDoc err =
678+ case err of
679+ BadCommand badName suggestions lastSuggestion ->
680+ fillSep $
681+ [ text "There is no"
682+ , code badName
683+ , text "command."
684+ , text "Did you mean"
685+ ]
686+ ++ oxfordify (map code suggestions) "or" (code lastSuggestion <> text "?")
687+
688+ NoCommand (BadArgs argError) ->
689+ argErrorToDoc Nothing argError
690+
691+ NoCommand (BadFlags flagError) ->
692+ flagErrorToDoc Nothing flagError
693+
694+ AfterCommand name (BadArgs argError) ->
695+ argErrorToDoc (Just name) argError
696+
697+ AfterCommand name (BadFlags flagError) ->
698+ flagErrorToDoc (Just name) flagError
699+
700+
701+
702+-- ARG FAILURE
703+
704+
705+argErrorToDoc :: Maybe String -> ArgError -> Doc
706+argErrorToDoc maybeCommand argError =
707+ case argError of
708+ NoneOf argErrors ->
709+ text $ "TODO - " ++ show (map (argErrorToDoc maybeCommand) argErrors)
710+
711+ MissingArg (ParserInfo tipe) ->
712+ text $ "TODO - " ++ tipe
713+
714+ BadArg chunk _parserError ->
715+ text $ "TODO - " ++ chunk
716+
717+ ExtraArgs extraChunks ->
718+ text $ "TODO - " ++ show extraChunks
719+
720+
721+
722+-- FLAG FAILURE
723+
724+
725+flagErrorToDoc :: Maybe String -> FlagError -> Doc
726+flagErrorToDoc maybeCommand flagError =
727+ case flagError of
728+ BadOnOff name value ->
729+ let
730+ chunk =
731+ "--" ++ name ++ "=" ++ value
732+ in
733+ if null value then
734+ flagErrorToDocHelp "This on/off flag has a trailing equals sign:" chunk
735+ [ fillSep
736+ [ text "Just get rid of the equals sign, like this:"
737+ , green (text ("--" ++ name))
738+ ]
739+ ]
740+
741+ else
742+ flagErrorToDocHelp "This on/off flag was given a value:" chunk
743+ [ text "An on/off flag either exists or not, no need for an equals sign and value."
744+ , text "Maybe you want this instead?"
745+ , text ""
746+ , text " " <> green (text ("--" ++ name))
747+ , text ""
748+ ]
749+
750+ BadFlag name (ParserInfo tipe) Nothing ->
751+ flagErrorToDocHelp
752+ "This flag cannot appear without a value:"
753+ ("--" ++ name)
754+ [ text $ "It needs a " ++ tipe ++ " value."
755+ ]
756+
757+ BadFlag name (ParserInfo tipe) (Just (value, parserError)) ->
758+ flagErrorToDocHelp
759+ "This flag was given a bad value:"
760+ ("--" ++ name ++ "=" ++ value)
761+ [ fillSep $ map text $ words $
762+ "I need a " ++ tipe ++ " value, but "
763+ ++
764+ case parserError of
765+ Expecting expectedType ->
766+ value ++ " is not a valid " ++ expectedType ++ "."
767+ ]
768+
769+ Unrecognized chunk [] ->
770+ let
771+ explanation =
772+ case maybeCommand of
773+ Nothing ->
774+ "I am not expecting any flags."
775+
776+ Just command ->
777+ "The `" ++ command ++ "` command does not expect any flags."
778+ in
779+ flagErrorToDocHelp "Get rid of this flag:" chunk $
780+ [ fillSep (map text (words explanation))
781+ ]
782+
783+ Unrecognized chunk info ->
784+ case takeWhile ('=' /=) (dropWhile ('-' ==) chunk) of
785+ "" ->
786+ flagErrorToDocHelp "This is not a valid flag:" chunk
787+ [ text "Valid flags look like --output=FILE"
788+ ]
789+
790+ name ->
791+ let
792+ suggestions =
793+ nearbyNames id name (map fst info)
794+ in
795+ flagErrorToDocHelp "I do not recognize this flag:" chunk $
796+ unrecognizedExplanation $
797+ if null suggestions then map fst info else suggestions
798+
799+
800+flagErrorToDocHelp :: String -> String -> [Doc] -> Doc
801+flagErrorToDocHelp summary original explanation =
802+ vcat $
803+ [ text summary
804+ , text ""
805+ , text " " <> red (text original)
806+ , text ""
807+ ]
808+ ++ explanation
809+
810+
811+unrecognizedExplanation :: [String] -> [Doc]
812+unrecognizedExplanation suggestions =
813+ let
814+ toBullet name =
815+ text " " <> green (text ("--" ++ name))
816+ in
817+ case suggestions of
818+ [] ->
819+ []
820+
821+ [suggestion] ->
822+ [ text "Looks like a typo. Maybe you want:"
823+ , text ""
824+ , toBullet suggestion
825+ , text ""
826+ ]
827+
828+ _ ->
829+ [ text "Maybe you want one of these?"
830+ , text ""
831+ ]
832+ ++ map toBullet suggestions
833+ ++ [ text "" ]
834+
835+
836+code :: String -> Doc
837+code str =
838+ red (text str)
839+
840+
841+oxfordify :: [Doc] -> String -> Doc -> [Doc]
842+oxfordify chunks conjuction lastChunk =
843+ case chunks of
844+ [] ->
845+ [ lastChunk ]
846+
847+ [chunk] ->
848+ [ chunk, text conjuction, lastChunk ]
849+
850+ _ ->
851+ map (<> comma) chunks ++ [ text conjuction, lastChunk ]
cli/src/Develop.hsnew file+266
@@ -0,0 +1,266 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Develop (run) where
4+
5+import Control.Applicative ((<|>))
6+import Control.Concurrent (threadDelay)
7+import Control.Monad (guard)
8+import Control.Monad.Trans (MonadIO(liftIO))
9+import qualified Data.HashMap.Strict as HashMap
10+import qualified Data.ByteString.Char8 as BSC
11+import System.Directory
12+import System.FilePath
13+import Snap.Core
14+import Snap.Http.Server
15+import Snap.Util.FileServe
16+import qualified Text.Blaze.Html5 as H
17+import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
18+
19+import qualified CommandLine.Args as Args
20+import qualified Develop.Compile as Compile
21+import qualified Develop.Generate.Help as Generate
22+import qualified Develop.Generate.Index as Index
23+import qualified Develop.Generate.NotFound as NotFound
24+import qualified Develop.StaticFiles as StaticFiles
25+
26+
27+
28+-- RUN THE DEV SERVER
29+
30+
31+run :: Args.DevFlags -> IO ()
32+run (Args.DevFlags maybePort) =
33+ -- TODO get `elm reactor` running again
34+ if True then
35+ putStrLn $
36+ "The reactor is not available in the ALPHA period.\n\
37+ \\n\
38+ \The goal is for package authors to get code updated and give early feedback.\n\
39+ \Professionals and hobbyists should NOT be ugrading at this time!\n"
40+ else
41+ let
42+ port =
43+ maybe 8000 id maybePort
44+ in
45+ do putStrLn (startupMessage port)
46+
47+ httpServe (config port) $
48+ serveFiles
49+ <|> route [ ("_compile", compile) ]
50+ <|> route [ ("_elm/move-to-root", moveToRoot)]
51+ <|> route [ ("_elm/create-new-project", createNewProject)]
52+ <|> serveDirectoryWith directoryConfig "."
53+ <|> serveAssets
54+ <|> error404
55+
56+
57+config :: Int -> Config Snap a
58+config port =
59+ defaultConfig
60+ # setVerbose False
61+ # setPort port
62+ # setAccessLog ConfigNoLog
63+ # setErrorLog ConfigNoLog
64+
65+
66+(#) :: a -> (a -> b) -> b
67+(#) value func =
68+ func value
69+
70+
71+
72+-- HELPERS
73+
74+
75+startupMessage :: Int -> String
76+startupMessage port =
77+ "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."
78+
79+
80+directoryConfig :: MonadSnap m => DirectoryConfig m
81+directoryConfig =
82+ let
83+ customGenerator directory =
84+ do project <- liftIO (Index.getProject directory)
85+ modifyResponse $ setContentType "text/html; charset=utf-8"
86+ writeBuilder (Blaze.renderHtmlBuilder (Index.toHtml project))
87+ in
88+ fancyDirectoryConfig
89+ { indexFiles = []
90+ , indexGenerator = customGenerator
91+ }
92+
93+
94+compile :: Snap ()
95+compile =
96+ do file <- getSafePath
97+ guard =<< liftIO (doesFileExist file)
98+ modifyResponse (setContentType "text/javascript")
99+ writeBS =<< liftIO (Compile.toJavaScript file)
100+
101+
102+error404 :: Snap ()
103+error404 =
104+ do modifyResponse $ setResponseStatus 404 "Not Found"
105+ modifyResponse $ setContentType "text/html; charset=utf-8"
106+ writeBuilder (Blaze.renderHtmlBuilder NotFound.html)
107+
108+
109+
110+-- CREATE NEW PROJECT
111+
112+
113+createNewProject :: Snap ()
114+createNewProject =
115+ do liftIO $ threadDelay (2 * 1000 * 1000)
116+ return ()
117+
118+
119+moveToRoot :: Snap ()
120+moveToRoot =
121+ liftIO Index.moveToRoot
122+
123+
124+
125+-- SERVE FILES
126+
127+
128+serveFiles :: Snap ()
129+serveFiles =
130+ do file <- getSafePath
131+ guard =<< liftIO (doesFileExist file)
132+ serveElm file <|> serveFilePretty file
133+
134+
135+serveHtml :: MonadSnap m => H.Html -> m ()
136+serveHtml html =
137+ do modifyResponse (setContentType "text/html")
138+ writeBuilder (Blaze.renderHtmlBuilder html)
139+
140+
141+
142+-- SERVE FILES + CODE HIGHLIGHTING
143+
144+
145+serveFilePretty :: FilePath -> Snap ()
146+serveFilePretty file =
147+ let
148+ possibleExtensions =
149+ getSubExts (takeExtensions file)
150+ in
151+ case mconcat (map lookupMimeType possibleExtensions) of
152+ Nothing ->
153+ serveCode file
154+
155+ Just mimeType ->
156+ serveFileAs mimeType file
157+
158+
159+getSubExts :: String -> [String]
160+getSubExts fullExtension =
161+ if null fullExtension then
162+ []
163+
164+ else
165+ fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
166+
167+
168+serveCode :: String -> Snap ()
169+serveCode file =
170+ do code <- liftIO (readFile file)
171+ serveHtml $ Generate.makeCodeHtml ('~' : '/' : file) code
172+
173+
174+
175+-- SERVE ELM
176+
177+
178+serveElm :: FilePath -> Snap ()
179+serveElm file =
180+ do guard (takeExtension file == ".elm")
181+ serveHtml (Generate.makeElmHtml file)
182+
183+
184+
185+-- SERVE STATIC ASSETS
186+
187+
188+serveAssets :: Snap ()
189+serveAssets =
190+ do file <- getSafePath
191+ case StaticFiles.lookup file of
192+ Nothing ->
193+ pass
194+
195+ Just (content, mimeType) ->
196+ do modifyResponse (setContentType $ BSC.pack (mimeType ++ ";charset=utf-8"))
197+ writeBS content
198+
199+
200+
201+-- MIME TYPES
202+
203+
204+lookupMimeType :: FilePath -> Maybe BSC.ByteString
205+lookupMimeType ext =
206+ HashMap.lookup ext mimeTypeDict
207+
208+
209+(==>) :: a -> b -> (a,b)
210+(==>) a b =
211+ (a, b)
212+
213+
214+mimeTypeDict :: HashMap.HashMap FilePath BSC.ByteString
215+mimeTypeDict =
216+ HashMap.fromList
217+ [ ".asc" ==> "text/plain"
218+ , ".asf" ==> "video/x-ms-asf"
219+ , ".asx" ==> "video/x-ms-asf"
220+ , ".avi" ==> "video/x-msvideo"
221+ , ".bz2" ==> "application/x-bzip"
222+ , ".css" ==> "text/css"
223+ , ".dtd" ==> "text/xml"
224+ , ".dvi" ==> "application/x-dvi"
225+ , ".gif" ==> "image/gif"
226+ , ".gz" ==> "application/x-gzip"
227+ , ".htm" ==> "text/html"
228+ , ".html" ==> "text/html"
229+ , ".ico" ==> "image/x-icon"
230+ , ".jpeg" ==> "image/jpeg"
231+ , ".jpg" ==> "image/jpeg"
232+ , ".js" ==> "text/javascript"
233+ , ".json" ==> "application/json"
234+ , ".m3u" ==> "audio/x-mpegurl"
235+ , ".mov" ==> "video/quicktime"
236+ , ".mp3" ==> "audio/mpeg"
237+ , ".mpeg" ==> "video/mpeg"
238+ , ".mpg" ==> "video/mpeg"
239+ , ".ogg" ==> "application/ogg"
240+ , ".pac" ==> "application/x-ns-proxy-autoconfig"
241+ , ".pdf" ==> "application/pdf"
242+ , ".png" ==> "image/png"
243+ , ".qt" ==> "video/quicktime"
244+ , ".sig" ==> "application/pgp-signature"
245+ , ".spl" ==> "application/futuresplash"
246+ , ".svg" ==> "image/svg+xml"
247+ , ".swf" ==> "application/x-shockwave-flash"
248+ , ".tar" ==> "application/x-tar"
249+ , ".tar.bz2" ==> "application/x-bzip-compressed-tar"
250+ , ".tar.gz" ==> "application/x-tgz"
251+ , ".tbz" ==> "application/x-bzip-compressed-tar"
252+ , ".text" ==> "text/plain"
253+ , ".tgz" ==> "application/x-tgz"
254+ , ".ttf" ==> "application/x-font-truetype"
255+ , ".txt" ==> "text/plain"
256+ , ".wav" ==> "audio/x-wav"
257+ , ".wax" ==> "audio/x-ms-wax"
258+ , ".wma" ==> "audio/x-ms-wma"
259+ , ".wmv" ==> "video/x-ms-wmv"
260+ , ".xbm" ==> "image/x-xbitmap"
261+ , ".xml" ==> "text/xml"
262+ , ".xpm" ==> "image/x-xpixmap"
263+ , ".xwd" ==> "image/x-xwindowdump"
264+ , ".zip" ==> "application/zip"
265+ ]
266+
cli/src/Develop/Compile.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Develop.Compile
4+ ( toJavaScript
5+ )
6+ where
7+
8+
9+import qualified Data.ByteString.Char8 as BS
10+
11+
12+
13+-- TO JAVASCRIPT
14+
15+
16+toJavaScript :: FilePath -> IO BS.ByteString
17+toJavaScript filePath =
18+ do result <- error "TODO toJavaScript" filePath
19+ case result of
20+ Right (code, name) ->
21+ return $ BS.append code $ BS.pack $
22+ "var runElmProgram = Elm." ++ name ++ ".fullscreen;"
23+
24+ Left errMsg ->
25+ return $ BS.concat $
26+ [ BS.pack $ "function runElmProgram() {\n\tElm.Errors.fullscreen("
27+ , error "TODO show compile issues" errMsg
28+ , ");\n}"
29+ ]
30+
cli/src/Develop/Generate/Help.hsnew file+113
@@ -0,0 +1,113 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Develop.Generate.Help
4+ ( makeHtml
5+ , makeCodeHtml
6+ , makeElmHtml
7+ )
8+ where
9+
10+import Text.Blaze.Html5 ((!))
11+import qualified Text.Blaze.Html5 as H
12+import qualified Text.Blaze.Html5.Attributes as A
13+
14+import qualified Develop.StaticFiles as StaticFiles
15+
16+
17+
18+-- PAGES
19+
20+
21+makeHtml :: String -> String -> String -> H.Html
22+makeHtml title jsFile initCode =
23+ H.docTypeHtml $ do
24+ H.head $ do
25+ H.meta ! A.charset "UTF-8"
26+ H.title $ H.toHtml title
27+ H.link
28+ ! A.type_ "text/css"
29+ ! A.rel "stylesheet"
30+ ! A.href (H.toValue ("/" ++ StaticFiles.cssPath))
31+ H.script ! A.src (H.toValue jsFile) $ ""
32+
33+ H.body $ do
34+ H.script $ H.preEscapedToMarkup initCode
35+
36+
37+
38+-- CODE
39+
40+
41+makeCodeHtml :: String -> String -> H.Html
42+makeCodeHtml title code =
43+ H.docTypeHtml $ do
44+ H.head $ do
45+ H.meta ! A.charset "UTF-8"
46+ H.title $ H.toHtml title
47+ H.style ! A.type_ "text/css" $ codeStyle
48+
49+ H.link ! A.rel "stylesheet" ! A.href "//cdnjs.cloudflare.com/ajax/libs/highlight.js/9.3.0/styles/default.min.css"
50+ H.script ! A.src "//cdnjs.cloudflare.com/ajax/libs/highlight.js/9.3.0/highlight.min.js" $ ""
51+ H.script $ "if (hljs) { hljs.initHighlightingOnLoad(); }"
52+
53+ H.body ! A.style "background-color: #F0F0F0;" $ do
54+ H.pre $ H.code $ H.toHtml code
55+
56+
57+codeStyle :: H.Html
58+codeStyle =
59+ H.toHtml $ unlines $
60+ [ "html, head, body, pre {"
61+ , " margin: 0;"
62+ , " height: 100%;"
63+ , "}"
64+ , "body {"
65+ , " font-family: 'Source Code Pro', monospace;"
66+ , "}"
67+ ]
68+
69+
70+
71+-- ELM CODE
72+
73+
74+makeElmHtml :: FilePath -> H.Html
75+makeElmHtml filePath =
76+ H.docTypeHtml $ do
77+ H.head $ do
78+ H.meta ! A.charset "UTF-8"
79+ H.title $ H.toHtml ("~/" ++ filePath)
80+ H.style ! A.type_ "text/css" $ elmStyle
81+
82+ H.body $ do
83+ H.div ! A.style waitingStyle $ do
84+ H.div ! A.style "font-size: 3em;" $ "Building your project!"
85+ H.img ! A.src (H.toValue StaticFiles.waitingPath)
86+ H.div ! A.style "font-size: 1em" $ "With new projects, I need a bunch of extra time to download packages."
87+
88+ H.script ! A.src (H.toValue ("/_compile/" ++ filePath)) ! A.charset "utf-8" $ ""
89+ H.script $ H.preEscapedToMarkup $ unlines $
90+ [ "while (document.body.firstChild) {"
91+ , " document.body.removeChild(document.body.firstChild);"
92+ , "}"
93+ , "runElmProgram();"
94+ ]
95+
96+
97+elmStyle :: H.Html
98+elmStyle =
99+ H.toHtml $ unlines $
100+ [ "@import url(http://fonts.googleapis.com/css?family=Source+Sans+Pro);"
101+ , "html, head, body {"
102+ , " margin: 0;"
103+ , " height: 100%;"
104+ , "}"
105+ ]
106+
107+
108+waitingStyle :: H.AttributeValue
109+waitingStyle =
110+ H.stringValue $
111+ "width: 100%; height: 100%; display: flex; flex-direction: column;"
112+ ++ " justify-content: center; align-items: center; color: #9A9A9A;"
113+ ++ " font-family: 'Source Sans Pro';"
cli/src/Develop/Generate/Index.hsnew file+204
@@ -0,0 +1,204 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Develop.Generate.Index
4+ ( toHtml
5+ , getProject
6+ , moveToRoot
7+ )
8+ where
9+
10+import Control.Monad (filterM)
11+import qualified Data.ByteString.Builder as B
12+import qualified Data.ByteString.Lazy.UTF8 as Utf8
13+import qualified Data.List as List
14+import qualified Data.Text as Text
15+import qualified Data.Text.IO as Text
16+import qualified System.Directory as Dir
17+import System.FilePath ((</>), joinPath, splitDirectories, takeExtension)
18+import qualified Text.Blaze.Html5 as H
19+
20+import qualified Develop.Generate.Help as Help
21+import qualified Develop.StaticFiles as StaticFiles
22+import qualified Json.Encode as E
23+
24+
25+
26+-- PROJECT
27+
28+
29+data Project =
30+ Project
31+ { _root :: FilePath
32+ , _info :: PerhapsInfo
33+ }
34+
35+
36+data PerhapsInfo
37+ = Bad (Maybe FilePath)
38+ | Good Info
39+
40+
41+data Info =
42+ Info
43+ { _pwd :: [String]
44+ , _dirs :: [FilePath]
45+ , _files :: [(FilePath, Bool)]
46+ , _readme :: Maybe Text.Text
47+ , _config :: Text.Text
48+ }
49+
50+
51+
52+-- JSON
53+
54+
55+goodToJson :: FilePath -> Info -> String
56+goodToJson root (Info pwd dirs files readme config) =
57+ Utf8.toString $ B.toLazyByteString $ E.encodeUgly $
58+ E.object
59+ [ ( "root", encodeFilePath root )
60+ , ( "pwd", E.list encodeFilePath pwd )
61+ , ( "dirs", E.list encodeFilePath dirs )
62+ , ( "files", E.list encodeFile files )
63+ , ( "readme", maybe E.null E.text readme )
64+ , ( "config", E.text config )
65+ ]
66+
67+
68+encodeFilePath :: FilePath -> E.Value
69+encodeFilePath filePath =
70+ E.text (Text.pack filePath)
71+
72+
73+encodeFile :: (FilePath, Bool) -> E.Value
74+encodeFile (file, hasMain) =
75+ E.array [ encodeFilePath file, E.bool hasMain ]
76+
77+
78+badJson :: FilePath -> Maybe FilePath -> String
79+badJson root potentialRoot =
80+ Utf8.toString $ B.toLazyByteString $ E.encodeUgly $
81+ E.object
82+ [ ( "root", encodeFilePath root )
83+ , ( "suggestion", maybe E.null encodeFilePath potentialRoot )
84+ ]
85+
86+
87+
88+-- GENERATE HTML
89+
90+
91+toHtml :: Project -> H.Html
92+toHtml (Project root perhapsInfo) =
93+ case perhapsInfo of
94+ Good info@(Info pwd _ _ _ _) ->
95+ Help.makeHtml
96+ (List.intercalate "/" ("~" : pwd))
97+ ("/" ++ StaticFiles.elmPath)
98+ ("Elm.Index.fullscreen(" ++ goodToJson root info ++ ");")
99+
100+ Bad suggestion ->
101+ Help.makeHtml
102+ (maybe "New Project!" (const "Existing Project?") suggestion)
103+ ("/" ++ StaticFiles.elmPath)
104+ ("Elm.Start.fullscreen(" ++ badJson root suggestion ++ ");")
105+
106+
107+
108+-- GET PROJECT
109+
110+
111+getProject :: FilePath -> IO Project
112+getProject directory =
113+ do root <- Dir.getCurrentDirectory
114+ exists <- Dir.doesFileExist "elm.json"
115+ Project root <$>
116+ case exists of
117+ False ->
118+ Bad <$> findNearestConfig (splitDirectories root)
119+
120+ True ->
121+ do json <- Text.readFile "elm.json"
122+ Good <$> getInfo json directory
123+
124+
125+findNearestConfig :: [String] -> IO (Maybe FilePath)
126+findNearestConfig dirs =
127+ if null dirs then
128+ return Nothing
129+
130+ else
131+ do exists <- Dir.doesFileExist (joinPath dirs </> "elm.json")
132+ if exists
133+ then return (Just (joinPath dirs))
134+ else findNearestConfig (init dirs)
135+
136+
137+moveToRoot :: IO ()
138+moveToRoot =
139+ do subDir <- Dir.getCurrentDirectory
140+ maybeRoot <- findNearestConfig (splitDirectories subDir)
141+ case maybeRoot of
142+ Nothing ->
143+ return ()
144+
145+ Just root ->
146+ Dir.setCurrentDirectory root
147+
148+
149+
150+-- GET INFO
151+
152+
153+getInfo :: Text.Text -> FilePath -> IO Info
154+getInfo config directory =
155+ do (dirs, files) <- getDirectoryInfo directory
156+ readme <- getReadme directory
157+ return $
158+ Info
159+ { _pwd = dropWhile ("." ==) (splitDirectories directory)
160+ , _dirs = dirs
161+ , _files = files
162+ , _readme = readme
163+ , _config = config
164+ }
165+
166+
167+
168+-- README
169+
170+
171+getReadme :: FilePath -> IO (Maybe Text.Text)
172+getReadme dir =
173+ do let readmePath = dir </> "README.md"
174+ exists <- Dir.doesFileExist readmePath
175+ if exists
176+ then Just <$> Text.readFile readmePath
177+ else return Nothing
178+
179+
180+
181+-- DIRECTORIES / FILES
182+
183+
184+getDirectoryInfo :: FilePath -> IO ([FilePath], [(FilePath, Bool)])
185+getDirectoryInfo dir =
186+ do contents <- Dir.getDirectoryContents dir
187+
188+ allDirs <- filterM (Dir.doesDirectoryExist . (dir </>)) contents
189+ rawFiles <- filterM (Dir.doesFileExist . (dir </>)) contents
190+
191+ files <- mapM (inspectFile dir) rawFiles
192+
193+ return (allDirs, files)
194+
195+
196+inspectFile :: FilePath -> FilePath -> IO (FilePath, Bool)
197+inspectFile dir filePath =
198+ if takeExtension filePath == ".elm" then
199+ do source <- Text.readFile (dir </> filePath)
200+ let hasMain = Text.isInfixOf "\nmain " source
201+ return (filePath, hasMain)
202+
203+ else
204+ return (filePath, False)
cli/src/Develop/Generate/NotFound.hsnew file+14
@@ -0,0 +1,14 @@
1+module Develop.Generate.NotFound where
2+
3+import qualified Text.Blaze.Html5 as H
4+
5+import qualified Develop.StaticFiles as StaticFiles
6+import qualified Develop.Generate.Help as Help
7+
8+
9+html :: H.Html
10+html =
11+ Help.makeHtml
12+ "Page Not Found"
13+ ("/" ++ StaticFiles.elmPath)
14+ "Elm.NotFound.fullscreen();"
cli/src/Develop/Socket.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Develop.Socket (watchFile) where
4+
5+import Control.Concurrent (forkIO, threadDelay)
6+import Control.Exception (SomeException, catch)
7+import qualified Data.ByteString.Char8 as BS
8+import qualified Network.WebSockets as WS
9+import qualified System.FSNotify.Devel as Notify
10+import qualified System.FSNotify as Notify
11+
12+
13+
14+watchFile :: FilePath -> WS.PendingConnection -> IO ()
15+watchFile watchedFile pendingConnection =
16+ do connection <- WS.acceptRequest pendingConnection
17+
18+ Notify.withManager $ \mgmt ->
19+ do stop <- Notify.treeExtAny mgmt "." ".elm" print
20+ tend connection
21+ stop
22+
23+
24+tend :: WS.Connection -> IO ()
25+tend connection =
26+ let
27+ pinger :: Integer -> IO a
28+ pinger n =
29+ do threadDelay (5 * 1000 * 1000)
30+ WS.sendPing connection (BS.pack (show n))
31+ pinger (n + 1)
32+
33+ receiver :: IO ()
34+ receiver =
35+ do _ <- WS.receiveDataMessage connection
36+ receiver
37+
38+ shutdown :: SomeException -> IO ()
39+ shutdown _ =
40+ return ()
41+ in
42+ do _pid <- forkIO (receiver `catch` shutdown)
43+ pinger 1 `catch` shutdown
cli/src/Develop/StaticFiles.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+module Develop.StaticFiles
4+ ( lookup
5+ , cssPath
6+ , elmPath
7+ , waitingPath
8+ )
9+ where
10+
11+import Prelude hiding (lookup)
12+import qualified Data.ByteString as BS
13+import Data.FileEmbed (bsToExp)
14+import qualified Data.HashMap.Strict as HM
15+import Language.Haskell.TH (runIO)
16+
17+import qualified Develop.StaticFiles.Build as Build
18+
19+
20+
21+-- FILE LOOKUP
22+
23+
24+type MimeType =
25+ String
26+
27+
28+lookup :: FilePath -> Maybe (BS.ByteString, MimeType)
29+lookup path =
30+ HM.lookup path dict
31+
32+
33+dict :: HM.HashMap FilePath (BS.ByteString, MimeType)
34+dict =
35+ HM.fromList
36+ [ faviconPath ==> (favicon , "image/x-icon")
37+ , waitingPath ==> (waiting , "image/gif")
38+ , elmPath ==> (elm , "application/javascript")
39+ , cssPath ==> (css , "text/css")
40+ , codeFontPath ==> (codeFont, "font/ttf")
41+ , sansFontPath ==> (sansFont, "font/ttf")
42+ ]
43+
44+
45+(==>) :: a -> b -> (a,b)
46+(==>) a b =
47+ (a, b)
48+
49+
50+
51+-- PATHS
52+
53+
54+faviconPath :: FilePath
55+faviconPath =
56+ "favicon.ico"
57+
58+
59+waitingPath :: FilePath
60+waitingPath =
61+ "_elm/waiting.gif"
62+
63+
64+elmPath :: FilePath
65+elmPath =
66+ "_elm/elm.js"
67+
68+
69+cssPath :: FilePath
70+cssPath =
71+ "_elm/styles.css"
72+
73+
74+codeFontPath :: FilePath
75+codeFontPath =
76+ "_elm/source-code-pro.ttf"
77+
78+
79+sansFontPath :: FilePath
80+sansFontPath =
81+ "_elm/source-sans-pro.ttf"
82+
83+
84+
85+-- ELM
86+
87+
88+elm :: BS.ByteString
89+elm =
90+ $(bsToExp =<< runIO Build.compile)
91+
92+
93+
94+-- CSS
95+
96+
97+css :: BS.ByteString
98+css =
99+ $(bsToExp =<< runIO (Build.readAsset "styles.css"))
100+
101+
102+
103+-- FONTS
104+
105+
106+codeFont :: BS.ByteString
107+codeFont =
108+ $(bsToExp =<< runIO (Build.readAsset "source-code-pro.ttf"))
109+
110+
111+sansFont :: BS.ByteString
112+sansFont =
113+ $(bsToExp =<< runIO (Build.readAsset "source-sans-pro.ttf"))
114+
115+
116+
117+-- IMAGES
118+
119+
120+favicon :: BS.ByteString
121+favicon =
122+ $(bsToExp =<< runIO (Build.readAsset "favicon.ico"))
123+
124+
125+waiting :: BS.ByteString
126+waiting =
127+ $(bsToExp =<< runIO (Build.readAsset "waiting.gif"))
cli/src/Develop/StaticFiles/Build.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Develop.StaticFiles.Build
4+ ( readAsset
5+ , compile
6+ )
7+ where
8+
9+
10+import Control.Monad (void)
11+import qualified Data.ByteString as BS
12+import qualified System.Directory as Dir
13+import System.FilePath ((</>))
14+
15+import qualified Elm.Compiler.Objects as Obj
16+import qualified Elm.Project as Project
17+import qualified Elm.Project.Flags as Flags
18+import qualified Reporting.Task as Task
19+import qualified Reporting.Progress.Terminal as Terminal
20+
21+
22+
23+-- ASSETS
24+
25+
26+readAsset :: FilePath -> IO BS.ByteString
27+readAsset path =
28+ BS.readFile ("ui" </> "assets" </> path)
29+
30+
31+
32+-- COMPILE
33+
34+
35+compile :: IO BS.ByteString
36+compile =
37+ if True then return "TODO" else
38+ do Dir.setCurrentDirectory "ui"
39+
40+ reporter <- Terminal.create
41+ void $ Task.run reporter $
42+ do summary <- Project.getRoot
43+ Project.compile options summary rootPaths
44+
45+ result <- BS.readFile tempFileName
46+ seq (BS.length result) (Dir.removeFile tempFileName)
47+
48+ Dir.setCurrentDirectory ".."
49+
50+ return result
51+
52+
53+options :: Flags.Options
54+options =
55+ Flags.Options Obj.Prod Obj.Client $
56+ Just (Flags.Custom Nothing tempFileName)
57+
58+
59+tempFileName :: FilePath
60+tempFileName =
61+ "elm.js"
62+
63+
64+rootPaths :: [FilePath]
65+rootPaths =
66+ [ "src" </> "Errors.elm"
67+ , "src" </> "Index.elm"
68+ , "src" </> "Start.elm"
69+ , "src" </> "NotFound.elm"
70+ ]
cli/src/Diff.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Diff (run) where
3+
4+
5+import Control.Monad (void)
6+
7+import qualified Elm.Diff as Diff
8+import qualified Reporting.Task as Task
9+import qualified Reporting.Progress.Terminal as Terminal
10+
11+
12+
13+-- RUN
14+
15+
16+run :: Diff.Args -> IO ()
17+run args =
18+ do reporter <- Terminal.create
19+ void $ Task.run reporter $ Diff.diff args
cli/src/Install.hsnew file+21
@@ -0,0 +1,21 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Install (run) where
3+
4+
5+import Control.Monad (void)
6+
7+import qualified Elm.Install as Install
8+import qualified Elm.Package as Pkg
9+import qualified Reporting.Task as Task
10+import qualified Reporting.Progress.Terminal as Terminal
11+
12+
13+
14+-- RUN
15+
16+
17+run :: Pkg.Name -> IO ()
18+run pkg =
19+ do reporter <- Terminal.create
20+ void $ Task.run reporter $
21+ Install.install pkg
cli/src/Main.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Main where
3+
4+import qualified System.Directory as Dir
5+import System.Exit (exitWith)
6+import qualified System.IO as IO
7+import qualified System.Process as Proc
8+import GHC.IO.Encoding (setLocaleEncoding, utf8)
9+
10+import qualified Elm.Compiler as Compiler
11+import qualified Elm.Package as Pkg
12+
13+import CommandLine.Args as Args
14+import qualified Bump
15+import qualified Develop
16+import qualified Diff
17+import qualified Install
18+import qualified Make
19+import qualified Publish
20+import qualified Repl
21+
22+
23+
24+-- MAIN
25+
26+
27+main :: IO ()
28+main =
29+ do setLocaleEncoding utf8
30+
31+ route <- Args.chomp
32+ case route of
33+ Naked () () ->
34+ putStrLn $
35+ "Elm " ++ Pkg.versionToString Compiler.version
36+ ++ " - Get started at <https://guide.elm-lang.org/>!"
37+
38+ Version () () ->
39+ putStrLn (Pkg.versionToString Compiler.version)
40+
41+ Install pkg () ->
42+ Install.run pkg
43+
44+ Publish () () ->
45+ Publish.run
46+
47+ Make paths flags ->
48+ Make.run paths flags
49+
50+ Bump () () ->
51+ Bump.run
52+
53+ Diff args () ->
54+ Diff.run args
55+
56+ Repl () flags ->
57+ Repl.run flags
58+
59+ Dev () flags ->
60+ Develop.run flags
61+
62+
63+attemptToRun :: String -> [String] -> IO ()
64+attemptToRun command args =
65+ do found <- Dir.findExecutable ("elm-" ++ command)
66+ case found of
67+ Nothing ->
68+ IO.hPutStrLn IO.stderr $
69+ "Could not find command `" ++ command ++ "`. Maybe there is a typo?\n\n\
70+ \Default commands include:\n\n"
71+ ++ availableCommands ++
72+ "\nWhen you try to run the command `" ++ command ++ "` we actually search for an\n\
73+ \ executable named elm-" ++ command ++ ". Are you able to run elm-" ++ command ++ "?\n\
74+ \ Is it on your PATH?"
75+
76+ Just path ->
77+ do (_, _, _, handle) <- Proc.createProcess (Proc.proc path args)
78+ exitWith =<< Proc.waitForProcess handle
79+
80+
81+usageMessage :: String
82+usageMessage =
83+ "Elm Platform " ++ Pkg.versionToString Compiler.version ++ " - a way to run all Elm tools\n\
84+ \\n\
85+ \Usage: elm <command> [<args>]\n\
86+ \\n\
87+ \Available commands include:\n\n"
88+ ++ availableCommands ++
89+ "\nYou can learn more about a specific command by running things like:\n\
90+ \\n\
91+ \ elm make --help\n\
92+ \ elm package --help\n\
93+ \ elm <command> --help\n\
94+ \\n\
95+ \In all these cases we are simply running 'elm-<command>' so if you create an\n\
96+ \executable named 'elm-foobar' you will be able to run it as 'elm foobar' as\n\
97+ \long as it appears on your PATH."
98+
99+
100+availableCommands :: String
101+availableCommands =
102+ " make Compile an Elm file or project into JS or HTML\n\
103+ \ package Manage packages from <http://package.elm-lang.org>\n\
104+ \ reactor Develop with compile-on-refresh and time-travel debugging\n\
105+ \ repl A REPL for running individual expressions\n"
cli/src/Make.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Make (run) where
3+
4+
5+import Control.Monad (void)
6+
7+import qualified Elm.Compiler.Objects as Obj
8+import qualified Elm.Project as Project
9+import qualified Elm.Project.Flags as Flags
10+import qualified Reporting.Task as Task
11+import qualified Reporting.Progress.Terminal as Terminal
12+
13+import qualified CommandLine.Args as Args
14+
15+
16+
17+-- RUN
18+
19+
20+run :: [FilePath] -> Args.MakeFlags -> IO ()
21+run paths flags =
22+ do reporter <- Terminal.create
23+ void $ Task.run reporter $
24+ do summary <- Project.getRoot
25+ Project.compile (toOptions flags) summary paths
26+
27+
28+-- TODO figure out --warn flag
29+toOptions :: Args.MakeFlags -> Flags.Options
30+toOptions (Args.MakeFlags _warn debug output server) =
31+ let
32+ mode = if debug then Obj.Debug else Obj.Prod
33+ target = if server then Obj.Server else Obj.Client
34+ in
35+ Flags.Options mode target output
cli/src/Publish.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Publish (run) where
3+
4+
5+import Control.Monad (void)
6+
7+import qualified Elm.Project as Project
8+import qualified Elm.Publish as Publish
9+import qualified Reporting.Task as Task
10+import qualified Reporting.Progress.Terminal as Terminal
11+
12+
13+
14+-- RUN
15+
16+
17+run :: IO ()
18+run =
19+ do reporter <- Terminal.create
20+ void $ Task.run reporter $
21+ do summary <- Project.getRoot
22+ Publish.publish summary
cli/src/Repl.hsnew file+386
@@ -0,0 +1,386 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Repl where
4+
5+
6+import Prelude hiding (lines, read)
7+import Control.Applicative ((<|>))
8+import Control.Monad.RWS (lift, liftIO)
9+import qualified Control.Monad.RWS as RWS
10+import qualified Data.ByteString.Builder as B
11+import qualified Data.ByteString.Char8 as BS
12+import qualified Data.ByteString.Lazy as LBS
13+import qualified Data.List as List
14+import qualified Data.Map as Map
15+import Data.Monoid ((<>))
16+import qualified Data.Text as Text
17+import qualified Data.Text.Encoding as Text
18+import qualified System.Console.Haskeline as Repl
19+import qualified System.Directory as Dir
20+import qualified System.Exit as Exit
21+import System.FilePath ((</>))
22+import qualified System.IO as IO
23+import qualified System.Process as Proc
24+
25+import qualified Elm.Compiler as Elm (version)
26+import qualified Elm.Name as N
27+import qualified Elm.Project as Project
28+import qualified Elm.Package as Pkg
29+import qualified Elm.PerUserCache as PerUserCache
30+import qualified Elm.Utils as Elm
31+import qualified Reporting.Task as Task
32+import qualified Reporting.Progress.Repl as Repl
33+
34+import qualified CommandLine.Args as Args
35+
36+
37+
38+-- RUN
39+
40+
41+run :: Args.ReplFlags -> IO ()
42+run (Args.ReplFlags maybeAlternateInterpreter) =
43+ do interpreter <- getInterpreter maybeAlternateInterpreter
44+ _ <- Project.getRootWithReplFallback
45+ putStrLn welcomeMessage
46+ settings <- initSettings
47+ let manager = Repl.runInputT settings (Repl.withInterrupt loop)
48+ (exitCode,_,_) <- RWS.runRWST manager interpreter initalState
49+ Exit.exitWith exitCode
50+
51+
52+type Runner =
53+ RWS.RWST FilePath () State IO
54+
55+
56+
57+-- LOOP
58+
59+
60+loop :: Repl.InputT Runner Exit.ExitCode
61+loop =
62+ do input <- Repl.handleInterrupt (return Skip) read
63+ maybe loop return =<< lift (eval input)
64+
65+
66+
67+-- READ
68+
69+
70+read :: Repl.InputT Runner Input
71+read =
72+ readHelp "> " []
73+
74+
75+readHelp :: String -> [String] -> Repl.InputT Runner Input
76+readHelp starter lines =
77+ do input <- Repl.getInputLine starter
78+ case input of
79+ Nothing ->
80+ return Exit
81+
82+ Just line ->
83+ if not (null line) && last line == '\\'
84+ then readHelp "| " (init line : lines)
85+ else return $ toInput $ List.intercalate "\n" $ reverse (line : lines)
86+
87+
88+
89+-- EVAL
90+
91+
92+eval :: Input -> Runner (Maybe Exit.ExitCode)
93+eval input =
94+ case input of
95+ Skip ->
96+ return Nothing
97+
98+ Exit ->
99+ return (Just Exit.ExitSuccess)
100+
101+ Reset ->
102+ do RWS.put initalState
103+ report "<reset>"
104+
105+ Help info ->
106+ report (helpMessage info)
107+
108+ Code entry ->
109+ Repl.handleInterrupt (report "<cancelled>") $
110+ do state@(State _ imports types defs tricks) <- RWS.get
111+ case entry of
112+ Elm.Import name src ->
113+ interpret None $ state { _imports = Map.insert name src imports }
114+
115+ Elm.Type name src ->
116+ interpret None $ state { _types = Map.insert name src types }
117+
118+ Elm.Def (Just name) src ->
119+ interpret (Def name) $ state { _defs = Map.insert name src defs }
120+
121+ Elm.Def Nothing src ->
122+ interpret None $ state { _tricks = src : tricks }
123+
124+ Elm.Other src ->
125+ interpret (Expr src) state
126+
127+ Elm.Annotation ->
128+ report "I cannot handle type annotations."
129+
130+ Elm.Port ->
131+ report "I cannot handle port declarations."
132+
133+
134+toUtf8 :: String -> BS.ByteString
135+toUtf8 string =
136+ LBS.toStrict (B.toLazyByteString (B.stringUtf8 string))
137+
138+
139+report :: String -> Runner (Maybe a)
140+report msg =
141+ do liftIO (putStrLn msg)
142+ return Nothing
143+
144+
145+data Output = None | Def N.Name | Expr Text.Text
146+
147+
148+interpret :: Output -> State -> Runner (Maybe a)
149+interpret def state =
150+ do reporter <- liftIO $ Repl.create
151+ result <- liftIO $ Task.run reporter $ compile def state
152+
153+ case result of
154+ Nothing ->
155+ return ()
156+
157+ Just maybePath ->
158+ do RWS.put (state { _count = _count state + 1 })
159+ maybe (return ()) interpretHelp maybePath
160+
161+ return Nothing
162+
163+
164+interpretHelp :: FilePath -> Runner ()
165+interpretHelp path =
166+ do interpreter <- RWS.ask
167+ let proc = (Proc.proc interpreter [path]) { Proc.std_in = Proc.CreatePipe }
168+ liftIO $ Proc.withCreateProcess proc $ \_ _ _ handle ->
169+ do _ <- Proc.waitForProcess handle
170+ Dir.removeFile path
171+
172+
173+
174+-- INPUT
175+
176+
177+data Input
178+ = Skip
179+ | Exit
180+ | Reset
181+ | Help (Maybe String)
182+ | Code Elm.Entry
183+
184+
185+toInput :: String -> Input
186+toInput string =
187+ case dropWhile (==' ') string of
188+ ":exit" ->
189+ Exit
190+
191+ ":help" ->
192+ Help Nothing
193+
194+ ":reset" ->
195+ Reset
196+
197+ ':' : rest ->
198+ Help (Just (takeWhile (/=' ') rest))
199+
200+ "" ->
201+ Skip
202+
203+ _ ->
204+ Code (Elm.parseEntry string)
205+
206+
207+
208+-- STATE
209+
210+
211+data State =
212+ State
213+ { _count :: !Int
214+ , _imports :: Map.Map N.Name Text.Text
215+ , _types :: Map.Map N.Name Text.Text
216+ , _defs :: Map.Map N.Name Text.Text
217+ , _tricks :: [Text.Text]
218+ }
219+
220+
221+initalState :: State
222+initalState =
223+ State 0 Map.empty Map.empty Map.empty []
224+
225+
226+compile :: Output -> State -> Task.Task (Maybe FilePath)
227+compile output (State count imports types defs tricks) =
228+ let
229+ elmSourceCode =
230+ (<>) "module ElmRepl exposing (..)\n\n" $
231+ addLines imports $ addLines types $ addLines defs $
232+ List.foldr (<>) mempty (map Text.encodeUtf8Builder tricks)
233+ in
234+ case output of
235+ None ->
236+ if Map.null types && Map.null defs && null tricks then
237+ evaluate (elmSourceCode <> "unit = ()") Nothing
238+ else
239+ evaluate elmSourceCode Nothing
240+
241+ Def name ->
242+ evaluate elmSourceCode (Just name)
243+
244+ Expr expr ->
245+ let
246+ name = N.addIndex "repl_value_" count
247+ text = Text.replace "\n" "\n " expr
248+ def = N.toBuilder name <> " =\n " <> Text.encodeUtf8Builder text <> "\n"
249+ in
250+ evaluate (elmSourceCode <> def) (Just name)
251+
252+
253+addLines :: Map.Map N.Name Text.Text -> B.Builder -> B.Builder
254+addLines dict builder =
255+ Map.foldr (\text b -> Text.encodeUtf8Builder text <> b) builder dict
256+
257+
258+evaluate :: B.Builder -> Maybe N.Name -> Task.Task (Maybe FilePath)
259+evaluate builder maybeName =
260+ Project.compileForRepl (LBS.toStrict (B.toLazyByteString builder)) maybeName
261+
262+
263+
264+-- SETTINGS
265+
266+
267+initSettings :: IO (Repl.Settings Runner)
268+initSettings =
269+ do cache <- PerUserCache.getReplRoot
270+ return $
271+ Repl.Settings
272+ { Repl.historyFile = Just (cache </> "history")
273+ , Repl.autoAddHistory = True
274+ , Repl.complete = Repl.completeWord Nothing " \n" lookupCompletions
275+ }
276+
277+
278+lookupCompletions :: String -> Runner [Repl.Completion]
279+lookupCompletions string =
280+ do (State _ imports types defs _) <- RWS.get
281+ return $
282+ addMatches string False defs $
283+ addMatches string False types $
284+ addMatches string True imports $
285+ addMatches string False commands []
286+
287+
288+commands :: Map.Map N.Name ()
289+commands =
290+ Map.fromList [ (":exit", ()), (":quit", ()), (":reset", ()), (":help", ()) ]
291+
292+
293+addMatches :: String -> Bool -> Map.Map N.Name v -> [Repl.Completion] -> [Repl.Completion]
294+addMatches string isFinished dict completions =
295+ Map.foldrWithKey (addMatch string isFinished) completions dict
296+
297+
298+addMatch :: String -> Bool -> N.Name -> v -> [Repl.Completion] -> [Repl.Completion]
299+addMatch string isFinished name _ completions =
300+ let suggestion = N.toString name in
301+ if List.isPrefixOf string suggestion then
302+ Repl.Completion (drop (length string) suggestion) suggestion isFinished : completions
303+ else
304+ completions
305+
306+
307+
308+-- WELCOME
309+
310+
311+welcomeMessage :: String
312+welcomeMessage =
313+ let
314+ starter =
315+ "---- Elm " ++ elmVersion ++ " "
316+ in
317+ starter ++ replicate (80 - length starter) '-' ++ "\n"
318+ ++ " :help for help, :exit to exit, more at <https://github.com/elm-lang/elm-repl>\n"
319+ ++ "--------------------------------------------------------------------------------"
320+
321+
322+elmVersion :: String
323+elmVersion =
324+ Pkg.versionToString Elm.version
325+
326+
327+
328+-- HELP MESSAGES
329+
330+
331+helpMessage :: Maybe String -> String
332+helpMessage maybeBadCommand =
333+ case maybeBadCommand of
334+ Nothing ->
335+ genericHelpMessage
336+
337+ Just command ->
338+ "I do not recognize the :" ++ command ++ " command. " ++ genericHelpMessage
339+
340+
341+genericHelpMessage :: String
342+genericHelpMessage =
343+ "Valid commands include:\n\
344+ \\n\
345+ \ :exit Exit the REPL\n\
346+ \ :help Show this information\n\
347+ \ :reset Clear all previous imports and definitions\n\
348+ \\n\
349+ \More info at <https://github.com/elm-lang/elm/blob/" ++ elmVersion ++ "/help/repl.md>\n"
350+
351+
352+
353+-- GET INTERPRETER
354+
355+
356+getInterpreter :: Maybe String -> IO FilePath
357+getInterpreter maybeName =
358+ case maybeName of
359+ Just name ->
360+ getInterpreterHelp name (Dir.findExecutable name)
361+
362+ Nothing ->
363+ getInterpreterHelp "node` or `nodejs" $
364+ do exe1 <- Dir.findExecutable "node"
365+ exe2 <- Dir.findExecutable "nodejs"
366+ return (exe1 <|> exe2)
367+
368+
369+getInterpreterHelp :: String -> IO (Maybe FilePath) -> IO FilePath
370+getInterpreterHelp name findExe =
371+ do maybePath <- findExe
372+ case maybePath of
373+ Just path ->
374+ return path
375+
376+ Nothing ->
377+ do IO.hPutStrLn IO.stderr (exeNotFound name)
378+ Exit.exitFailure
379+
380+
381+exeNotFound :: String -> String
382+exeNotFound name =
383+ "The REPL relies on node.js to execute JavaScript code outside the browser.\n"
384+ ++ "I could not find executable `" ++ name ++ "` on your PATH though!\n\n"
385+ ++ "You can install node.js from <http://nodejs.org/>. If it is already installed\n"
386+ ++ "but has a different name, use the --interpreter flag."