packages feed

sugar (empty) → 0.0.0

raw patch · 7 files changed

+500/−0 lines, 7 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, megaparsec, ordered-containers, safe, sugar, tasty, tasty-hspec, text, text-conversions, text-show, unordered-containers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Change log++sugar uses [Semantic Versioning][].+The change log is available through the [releases on GitHub][].++[Semantic Versioning]: http://semver.org/spec/v2.0.0.html+[releases on GitHub]: https://github.com/jxv/sugar/releases
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2022, Joe Vargas+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# sugar
+ Setup.hs view
@@ -0,0 +1,7 @@+-- This script is used to build and install your package. Typically you don't+-- need to change it. The Cabal documentation has more information about this+-- file: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain
+ src/Sugar.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP #-}+module Sugar+  ( Sugar(..)+  , Wrap(..)+  , Note+  , FromSugar(..)+  , ToSugar(..)+  , sugarTextMay+  , readSugarFromFile+  , readSugarListFromFile+  , parseSugarFromText+  , parseSugarListFromText+  , prettyPrintSugarIO+  , prettyPrintSugar+  ) where++import Control.Applicative (Alternative(..))+import Data.Void (Void)+import Data.Text (Text)+import Data.Map (Map)+import Data.Maybe (isNothing)+import Data.Text.Conversions (ToText(..), fromText, unUTF8, decodeConvertText, UTF8(..))+import Data.String (IsString(..))+import Data.Word (Word8,Word16,Word32,Word64)+import Data.Int (Int8,Int16,Int32,Int64)+import Data.Char (isSeparator)+import GHC.Generics (Generic)+import TextShow (TextShow, showt)++import qualified Data.Map as Map+import qualified Data.Serialize as Serialize+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P+import qualified Text.Megaparsec.Char.Lexer as L++---++data Sugar+  = Sugar'Unit Note+  | Sugar'Text Text Note+  | Sugar'List [Sugar] Wrap Note+  | Sugar'Map [(Sugar,Sugar)] Note+  deriving (Eq, Show, Generic)+  +data Wrap+  = Wrap'Square+  | Wrap'Paren+  deriving (Eq, Show, Generic)+  +type Note = Maybe Sugar+  +--++instance Serialize.Serialize Sugar where+  get = do+    tag <- Serialize.getWord8+    go tag+    where+      go :: Word8 -> Serialize.Get Sugar+      go 0 = Sugar'Unit <$> Serialize.get+      go 1 = Sugar'Text <$> getSerializedText <*> Serialize.get+      go 2 = Sugar'List <$> Serialize.get <*> Serialize.get <*> Serialize.get+      go 3 = Sugar'Map <$> Serialize.get <*> Serialize.get+      go _ = fail "No matching Sugar value"+      +      getSerializedText :: Serialize.Get Text+      getSerializedText = do+        txt <- (decodeConvertText . UTF8) <$> (Serialize.get :: Serialize.Get BS.ByteString)+        maybe (fail "Cannot deserialize text as UTF8") pure txt+  +  put (Sugar'Unit note) = do+    Serialize.put (0 :: Word8)+    Serialize.put note+  put (Sugar'Text txt note) = do+    Serialize.put (1 :: Word8)+    Serialize.put (unUTF8 $ fromText txt :: BS.ByteString)+    Serialize.put note+  put (Sugar'List xs w note) = do+    Serialize.put (2 :: Word8)+    Serialize.put xs+    Serialize.put w+    Serialize.put note+  put (Sugar'Map m note) = do+    Serialize.put (3 :: Word8)+    Serialize.put m+    Serialize.put note  ++instance Serialize.Serialize Wrap where++instance IsString Sugar where+  fromString str = Sugar'Text (toText str) Nothing++--++class FromSugar a where+  parseSugar :: Sugar -> Maybe a+  +instance FromSugar a => FromSugar [a] where+  parseSugar (Sugar'List xs _ _) = mapM parseSugar xs+  parseSugar _ = Nothing++sugarTextMay :: Sugar -> Maybe Text+sugarTextMay (Sugar'Text t _) = Just t+sugarTextMay _ = Nothing++--++class ToSugar a where+  toSugar :: a -> Sugar++instance ToSugar () where+  toSugar () = Sugar'Unit Nothing++instance ToSugar Text where+  toSugar t = Sugar'Text t Nothing++-- TODO: Review this if it causes problems in the REPL+instance ToSugar a => ToSugar [a] where+  toSugar xs = Sugar'List (map toSugar xs) Wrap'Square Nothing++instance (ToSugar a, ToSugar b) => ToSugar (Map a b) where+  toSugar m = Sugar'Map (map (\(k,v) -> (toSugar k, toSugar v)) $ Map.toList m) Nothing+  +instance (ToSugar a, ToSugar b) => ToSugar (a,b) where+  toSugar (a,b) = Sugar'List [toSugar a, toSugar b] Wrap'Paren Nothing++instance (ToSugar a, ToSugar b, ToSugar c) => ToSugar (a,b,c) where+  toSugar (a,b,c) = Sugar'List [toSugar a, toSugar b, toSugar c] Wrap'Paren Nothing++instance ToSugar Integer where toSugar = sugarShow+instance ToSugar Int where toSugar = sugarShow+instance ToSugar Int8 where toSugar = sugarShow+instance ToSugar Int16 where toSugar = sugarShow+instance ToSugar Int32 where toSugar = sugarShow+instance ToSugar Int64 where toSugar = sugarShow+instance ToSugar Word where toSugar = sugarShow+instance ToSugar Word8 where toSugar = sugarShow+instance ToSugar Word16 where toSugar = sugarShow+instance ToSugar Word32 where toSugar = sugarShow+instance ToSugar Word64 where toSugar = sugarShow+instance ToSugar Float where toSugar = sugarShow+instance ToSugar Double where toSugar = sugarShow++sugarShow :: TextShow a => a -> Sugar+sugarShow s = Sugar'Text (showt s) Nothing++---++data PrettyPrintConfig = PrettyPrintConfig+  { ppcTabbedSpaces :: Int+  } deriving (Show, Eq)+  +data PrettyPrintState = PrettyPrintState+  { ppsNesting :: Int+  } deriving (Show, Eq)++prettyPrintSugarIO :: Sugar -> IO ()+prettyPrintSugarIO = TIO.putStr . prettyPrintSugar++prettyPrintSugar :: Sugar -> Text+prettyPrintSugar = prettyPrintSugar' (PrettyPrintConfig 2)++prettyPrintSugar' :: PrettyPrintConfig -> Sugar -> Text+prettyPrintSugar' ppc = prettyPrintStep ppc (PrettyPrintState 0)++prettyPrintNesting :: PrettyPrintConfig -> PrettyPrintState -> Text+prettyPrintNesting ppc pps = T.replicate (ppcTabbedSpaces ppc * ppsNesting pps) " "++ppsIncrNesting :: PrettyPrintState -> PrettyPrintState+ppsIncrNesting pps = pps { ppsNesting = ppsNesting pps + 1 }++ppsDecrNesting :: PrettyPrintState -> PrettyPrintState+ppsDecrNesting pps = pps { ppsNesting = if n >= 1 then n else 0 }+  where+    n = ppsNesting pps - 1++ppNewLine :: PrettyPrintConfig -> PrettyPrintState -> Text+ppNewLine ppc pps = "\n" <> prettyPrintNesting ppc pps ++prettyPrintStep :: PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text+prettyPrintStep _ _ (Sugar'Unit note) = "()" <> minifyPrintNote note+prettyPrintStep _ _ (Sugar'Text txt note) = sanitizeText txt <> minifyPrintNote note+prettyPrintStep ppc pps (Sugar'List xs w note) =+    open+    <> T.concat (map (\x -> T.concat [ppNewLine ppc pps, prettyPrintStep ppc (ppsIncrNesting pps) x]) xs)+    <> ppNewLine ppc (ppsDecrNesting pps)+    <> close+    <> minifyPrintNote note+  where+    open, close :: Text+    (open,close) = case w of Wrap'Square -> ("[","]"); Wrap'Paren -> ("(",")")+prettyPrintStep ppc pps (Sugar'Map m note) = if ppsNesting pps == 0 && isNothing note then topLevel else nested+    where+      topLevel =+        T.concat (map (\(k,v) -> T.concat [prettyPrintStep ppc nextPps k, " ", prettyPrintStep ppc nextPps v, "\n"]) m)+      nested =+        "{"+        <> T.concat (map (\(k,v) -> T.concat [ppNewLine ppc pps, prettyPrintStep ppc nextPps k, " ", prettyPrintStep ppc nextPps v]) m)+        <> ppNewLine ppc (ppsDecrNesting pps)+        <> "}"+        <> minifyPrintNote note+      nextPps = ppsIncrNesting pps++minifyPrint :: Sugar -> Text+minifyPrint (Sugar'Unit note) = "()" <> minifyPrintNote note+minifyPrint (Sugar'Text txt note) = sanitizeText txt <> minifyPrintNote note+minifyPrint (Sugar'List xs w note) = open <> T.intercalate " " (map minifyPrint xs) <> close <> minifyPrintNote note+  where+    open, close :: Text+    (open,close) = case w of Wrap'Square -> ("[","]"); Wrap'Paren -> ("(",")")+minifyPrint (Sugar'Map m note) = "{" <> T.intercalate " " (map minifyPrint xs) <> "}" <> minifyPrintNote note+  where+    xs :: [Sugar]+    xs = (\(k,v) -> [k,v]) =<< m++minifyPrintNote :: Note -> Text+minifyPrintNote Nothing = ""+minifyPrintNote (Just s) = "<" <> minifyPrint s <> ">"++sanitizeText :: Text -> Text+sanitizeText t+  | T.length t == 0 = "\"\""+  | T.find (\c -> isSeparator c || elem c reservedChars) t /= Nothing = "\"" <> replaceDoubleQuotes t <> "\""+  | otherwise = t+  where+    replaceDoubleQuotes :: Text -> Text+    replaceDoubleQuotes = T.replace "\"" "\\\""+    +reservedChars :: [Char]+reservedChars = ['\"','[',']','<','>','(',')','{','}',';']++---+---++readSugarFromFile :: FilePath -> IO (Maybe Sugar)+readSugarFromFile path = do+  content <- TIO.readFile path+  return $ parseSugarFromText content++parseSugarFromText :: Text -> Maybe Sugar+parseSugarFromText t = case P.runParser sugarP "" t of+  Left _ -> Nothing+  Right s -> Just s+  +readSugarListFromFile :: FilePath -> IO (Maybe Sugar)+readSugarListFromFile path = do+  content <- TIO.readFile path+  return $ parseSugarListFromText content++parseSugarListFromText :: Text -> Maybe Sugar+parseSugarListFromText t = case P.runParser sugarNoBracketsListP "" t of +  Left _ -> Nothing+  Right s -> Just s++---+---++type Parser = P.Parsec Void Text++sugarP :: Parser Sugar+sugarP = P.choice [P.try noCurlysMapP, sugarP']++sugarNoBracketsListP :: Parser Sugar+sugarNoBracketsListP = P.choice [P.try noBracketsListP, sugarP']++sugarP' :: Parser Sugar+sugarP' = do+  c <- P.lookAhead P.anySingle+  case c of+    '\"' -> quotedTextP+    '(' -> P.choice [unitP, parenListP]+    ')' -> fail "Not valid Sugar"+    '[' -> squareListP+    ']' -> fail "Not valid Sugar"+    '{' -> mapP+    '}' -> fail "Not valid Sugar"+    '<' -> fail "Not valid Sugar"+    '>' -> fail "Not valid Sugar"+    _ -> unQuotedTextP++unitP :: Parser Sugar+unitP = P.string "()" *> sc *> (Sugar'Unit <$> noteP)++parenListP, squareListP :: Parser Sugar+parenListP = (\xs -> Sugar'List xs Wrap'Paren) <$> parensP (P.many sugarP') <*> noteP+squareListP = (\xs -> Sugar'List xs Wrap'Square) <$> (squareBracketsP $ sc *> P.many elementP <* sc) <*> noteP+  where+    elementP :: Parser Sugar+    elementP = sc *> sugarP' <* sc++noBracketsListP :: Parser Sugar+noBracketsListP = (\xs -> Sugar'List xs Wrap'Square) <$> (sc *> P.many elementP <* sc) <*> pure Nothing+  where+    elementP :: Parser Sugar+    elementP = sc *> sugarP' <* sc++mapP, noCurlysMapP :: Parser Sugar+mapP = Sugar'Map <$> (curlyBracesP $ sc *> P.many mapPairP <* sc) <*> noteP+noCurlysMapP = Sugar'Map <$> (sc *> P.many mapPairP <* sc) <*> pure Nothing++-- TODO: Instead of `P.space1`, use the same characters for `isSeparator`+mapPairP :: Parser (Sugar, Sugar)+mapPairP = (,) <$> sugarP' <*> (sc *> sugarP') <* sc++noteP :: Parser Note+noteP = P.optional $ angleBracketsP sugarP'++parensP, angleBracketsP, squareBracketsP, curlyBracesP :: Parser a -> Parser a+parensP = P.between (symbol "(") (symbol ")")+angleBracketsP = P.between (symbol "<") (symbol ">")+squareBracketsP = P.between (symbol "[") (symbol "]")+curlyBracesP = P.between (symbol "{") (symbol "}")++symbol :: Text -> Parser Text+symbol = L.symbol sc++quotedTextP, unQuotedTextP :: Parser Sugar+quotedTextP = Sugar'Text <$> doubleQuotedTextP_ <*> (sc *> noteP)+unQuotedTextP = Sugar'Text <$> notQuotedTextP_ <*> noteP++doubleQuotedTextP_, notQuotedTextP_ :: Parser Text+doubleQuotedTextP_ = T.pack <$> quotedP+  where+    quotedP :: Parser String+    quotedP = P.between (P.char '\"') (P.char '\"') (many (P.try escaped <|> normalChar))+       where+         escaped = '\"' <$ P.string "\\\""+         normalChar = P.satisfy (/='\"')+notQuotedTextP_ = P.takeWhileP (Just "Text char") (\c -> not $ isSeparator c || c == '\n' || elem c reservedChars)++sc :: Parser ()+sc = L.space+  ws+  (L.skipLineComment ";") -- TODO replace with ';' once issue 88 is fixed+  (L.skipBlockComment "#|" "|#")+  +ws :: Parser ()+ws = (P.newline <|> P.separatorChar) *> pure ()
+ sugar.cabal view
@@ -0,0 +1,56 @@+name: sugar+version: 0.0.0+synopsis: Legible data+homepage: https://github.com/jxv/sugar#readme+description: Please see the README on GitHub at <https://github.com/jxv/sugar#readme>+category: Text, Configuration+bug-reports: https://github.com/jxv/sugar/issues+author: Joe Vargas+maintainer: Joe Vargas+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: 1.14+extra-source-files:+    CHANGELOG.md+    LICENSE+    README.md++source-repository head+  type: git+  location: https://github.com/jxv/sugar++library+  exposed-modules:+      Sugar+  hs-source-dirs:+      src+  default-extensions:+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , bytestring+    , cereal+    , containers >0.5 && <1+    , megaparsec+    , ordered-containers+    , safe+    , text+    , text-conversions+    , text-show+    , unordered-containers+    , vector+  default-language: Haskell2010++test-suite sugar-test-suite+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      test-suite+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base+    , sugar+    , tasty+    , tasty-hspec+  default-language: Haskell2010
+ test-suite/Main.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP #-}+import Sugar+import qualified Test.Tasty+import Test.Tasty.Hspec++main :: IO ()+main = do+    test <- testSpec "sugar" spec+    Test.Tasty.defaultMain test++spec :: Spec+spec = parallel $ do+    it "is trivially true" $ do+        True `shouldBe` True++--+--++mySugar :: Sugar+mySugar = Sugar'Map [(Sugar'Text "key" Nothing, Sugar'Text "value" Nothing)] Nothing++mySugar' :: Sugar+mySugar' = Sugar'Map [+    (Sugar'Text "key" (Just "A-che-ora"), Sugar'Text "value" (Just "A che ora")),+    (Sugar'Text "anotherKey" Nothing, Sugar'Map+      [+        (Sugar'Text "a" Nothing, Sugar'Text "12345\"6789" Nothing),+        (Sugar'Text "c" Nothing, Sugar'Text "12345    6789" Nothing),+        (Sugar'Text "e" Nothing, Sugar'Text "123'456789" Nothing),+        (Sugar'Text "d" Nothing, Sugar'List ["", "", Sugar'List [Sugar'List [Sugar'List ["","",Sugar'Map [("",Sugar'Map [] Nothing),("",Sugar'Map [] Nothing)] Nothing] Wrap'Paren Nothing] Wrap'Square Nothing]Wrap'Paren Nothing] Wrap'Square Nothing)+      ]+      (Just "Hello"))+  ] Nothing++data Color+  = Color'R+  | Color'G+  | Color'B+  deriving (Show, Eq)++instance FromSugar Color where+  parseSugar (Sugar'Text a _) = case a of+    "R" -> Just Color'R+    "G" -> Just Color'G+    "B" -> Just Color'B+    _ -> Nothing+  parseSugar _ = Nothing++keyVal :: IO ()+keyVal = readSugarFromFile "keyValue.sg" >>= \(Just sg) -> prettyPrintSugarIO sg++large :: IO ()+large = readSugarFromFile "large.sg" >>= \(Just sg) -> prettyPrintSugarIO sg++mysugar :: IO ()+mysugar = readSugarFromFile "mysugar.sg" >>= \(Just sg) -> prettyPrintSugarIO sg++noline :: IO ()+noline = readSugarFromFile "noline.sg" >>= \(Just sg) -> prettyPrintSugarIO sg