-
Notifications
You must be signed in to change notification settings - Fork 696
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Rework show-build-info to use ProjectPlanning/Building infrastructure
This fixes a lot of edge cases for example where the package db wasn't created at the time of configuring. Manually doing the setup.hs wrapper stuff was hairy. It also changes the internal representation of JSON to Text rather than String, and introduces the buildinfo-components-only flag in the Cabal part to make it easier to stitch back the JSON into an array in cabal-install. Turns out we do need to keep the show-build-info part inside Cabal as we rely on LocalBuildInfo which can change between versions, and we would need to do this anyway if we wanted to utilise the ProjectPlanning/Building infrastructure.
- Loading branch information
Showing
37 changed files
with
328 additions
and
239 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,50 +1,65 @@ | ||
| -- | Extremely simple JSON helper. Don't do anything too fancy with this! | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
|
|
||
| -- | Extremely simple JSON helper. Don't do anything too fancy with this! | ||
| module Distribution.Utils.Json | ||
| ( Json(..) | ||
| , (.=) | ||
| , renderJson | ||
| ) where | ||
|
|
||
| import Data.Text (Text) | ||
| import qualified Data.Text as Text | ||
|
|
||
| data Json = JsonArray [Json] | ||
| | JsonBool !Bool | ||
| | JsonNull | ||
| | JsonNumber !Int | ||
| | JsonObject [(String, Json)] | ||
| | JsonString !String | ||
| | JsonObject [(Text, Json)] | ||
| | JsonRaw !Text | ||
| | JsonString !Text | ||
|
|
||
| renderJson :: Json -> ShowS | ||
| -- | A type to mirror 'ShowS' | ||
| type ShowT = Text -> Text | ||
|
|
||
| renderJson :: Json -> ShowT | ||
| renderJson (JsonArray objs) = | ||
| surround "[" "]" $ intercalate "," $ map renderJson objs | ||
| renderJson (JsonBool True) = showString "true" | ||
| renderJson (JsonBool False) = showString "false" | ||
| renderJson JsonNull = showString "null" | ||
| renderJson (JsonNumber n) = shows n | ||
| renderJson (JsonBool True) = showText "true" | ||
| renderJson (JsonBool False) = showText "false" | ||
| renderJson JsonNull = showText "null" | ||
| renderJson (JsonNumber n) = showText $ Text.pack (show n) | ||
| renderJson (JsonObject attrs) = | ||
| surround "{" "}" $ intercalate "," $ map render attrs | ||
| where | ||
| render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v | ||
| renderJson (JsonString s) = surround "\"" "\"" $ showString' s | ||
|
|
||
| surround :: String -> String -> ShowS -> ShowS | ||
| surround begin end middle = showString begin . middle . showString end | ||
|
|
||
| showString' :: String -> ShowS | ||
| showString' xs = showStringWorker xs | ||
| where | ||
| showStringWorker :: String -> ShowS | ||
| showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as | ||
| showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as | ||
| showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as | ||
| showStringWorker (x:as) = showString [x] . showStringWorker as | ||
| showStringWorker [] = showString "" | ||
|
|
||
| intercalate :: String -> [ShowS] -> ShowS | ||
| render (k,v) = (surround "\"" "\"" $ showText' k) . showText ":" . renderJson v | ||
| renderJson (JsonString s) = surround "\"" "\"" $ showText' s | ||
| renderJson (JsonRaw s) = showText s | ||
|
|
||
| surround :: Text -> Text -> ShowT -> ShowT | ||
| surround begin end middle = showText begin . middle . showText end | ||
|
|
||
| showText :: Text -> ShowT | ||
| showText = (<>) | ||
|
|
||
| showText' :: Text -> ShowT | ||
| showText' xs = showStringWorker xs | ||
| where | ||
| showStringWorker :: Text -> ShowT | ||
| showStringWorker t = | ||
| case Text.uncons t of | ||
| Just ('\r', as) -> showText "\\r" . showStringWorker as | ||
| Just ('\n', as) -> showText "\\n" . showStringWorker as | ||
| Just ('\"', as) -> showText "\\\"" . showStringWorker as | ||
| Just ('\\', as) -> showText "\\\\" . showStringWorker as | ||
| Just (x, as) -> showText (Text.singleton x) . showStringWorker as | ||
| Nothing -> showText "" | ||
|
|
||
| intercalate :: Text -> [ShowT] -> ShowT | ||
| intercalate sep = go | ||
| where | ||
| go [] = id | ||
| go [x] = x | ||
| go (x:xs) = x . showString' sep . go xs | ||
| go (x:xs) = x . showText' sep . go xs | ||
|
|
||
| (.=) :: String -> Json -> (String, Json) | ||
| (.=) :: Text -> Json -> (Text, Json) | ||
| k .= v = (k, v) |
Oops, something went wrong.