packages feed

sugar 0.0.0.1 → 0.0.1

raw patch · 10 files changed

+960/−428 lines, 10 filesdep +file-embeddep +hspecdep +storedep −megaparsec

Dependencies added: file-embed, hspec, store

Dependencies removed: megaparsec

Files

LICENSE view
@@ -1,29 +1,14 @@-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.+The BSD Zero Clause License (0BSD) -* 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.+Copyright (c) 2022 Joe Vargas. -* 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.+Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted. -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.+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
src/Sugar.hs view
@@ -1,340 +1,9 @@ {-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP #-} module Sugar-  ( Sugar(..)-  , Wrap(..)-  , Note-  , FromSugar(..)-  , ToSugar(..)-  , sugarTextMay-  , readSugarFromFile-  , readSugarListFromFile-  , parseSugarFromText-  , parseSugarListFromText-  , prettyPrintSugarIO-  , prettyPrintSugar+  ( module X   ) 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 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 :: Show a => a -> Sugar-sugarShow s = Sugar'Text (T.pack $ show 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 ()+import Sugar.Types as X+import Sugar.Lexer as X+import Sugar.Parser as X+import Sugar.IO as X
+ src/Sugar/IO.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP #-}+module Sugar.IO+  ( Sugar(..)+  , Wrap(..)+  , Note+  , FromSugar(..)+  , readSugarMay+  , sugarMapAsIxMap+  , ToSugar(..)+  , sugarTextMay+  , readSugarFromFile+  , readSugarListFromFile+  , parseSugarFromText+  , parseSugarListFromText+  , prettyPrintSugarIO+  , prettyPrintSugar+  , sugarLexerState+  ) where++import Data.Text (Text)+import Data.Maybe (isNothing)+import Data.Char (isSeparator)++import qualified Data.Text as T+import qualified Data.Text.IO as TIO++import Sugar.Types+import Sugar.Parser+import Sugar.Lexer++--++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 xs) = "<" <> T.intercalate " " (map minifyPrint xs) <> ">"++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 "\"" "\\\""++readSugarFromFile :: FilePath -> IO (Maybe Sugar)+readSugarFromFile path = do+  content <- TIO.readFile path+  return $ parseSugarFromText content++parseSugarFromText :: Text -> Maybe Sugar+parseSugarFromText t = case runParser sugarParseTopLevel (psSteps $ sugarLexerState (T.unpack t)) of+  (_, Left _) -> Nothing+  (_, Right s) -> Just $ flatten s++readSugarListFromFile :: FilePath -> IO (Maybe Sugar)+readSugarListFromFile path = do+  content <- TIO.readFile path+  return $ parseSugarListFromText content++parseSugarListFromText :: Text -> Maybe Sugar+parseSugarListFromText t = case runParser sugarParseList (psSteps $ sugarLexerState (T.unpack t)) of+  (_, Left _) -> Nothing+  (_, Right s) -> Just $ flatten s
+ src/Sugar/Lexer.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE TupleSections, OverloadedStrings #-}+module Sugar.Lexer+  ( LexerState(..)+  , LexemeStep+  , SourceLocation(..)+  , Lexeme(..)+  , sugarLexerState+  ) where++import Data.Char+import Safe.Exact (splitAtExactMay)++import Sugar.Types++data LexerState = LexerState+  { psSteps :: [LexemeStep]+  , psLocation :: SourceLocation+  } deriving (Show, Eq)++type LexemeStep = (SourceLocation, Lexeme)++data SourceLocation = SourceLocation+  { slLine :: Int+  , slColumn :: Int+  } deriving (Show, Eq)++data Lexeme+  = Lexeme'Start+  | Lexeme'OpenCurl+  | Lexeme'CloseCurl+  | Lexeme'OpenParen+  | Lexeme'CloseParen+  | Lexeme'OpenSquare+  | Lexeme'CloseSquare+  | Lexeme'OpenAngle+  | Lexeme'CloseAngle+  | Lexeme'StringStart+  | Lexeme'String String+  | Lexeme'QuoteStart+  | Lexeme'QuotedString String+  | Lexeme'QuoteEnd+  | Lexeme'SingleLineComment+  | Lexeme'MultiLineCommentStart+  | Lexeme'MultiLineCommentEnd+  deriving (Show, Eq)++sugarLexerState :: String -> LexerState+sugarLexerState s =+  let ls = go (stepReadSugarString s initLexerState)+  in ls { psSteps = reverse (psSteps ls) }+  where+    go (s',ps) = case s' of+      [] -> ps+      _ -> go (stepReadSugarString s' ps)+    initLexerState :: LexerState+    initLexerState = LexerState [] (SourceLocation 1 1)++incrColLoc :: SourceLocation -> SourceLocation+incrColLoc sl = sl { slColumn = slColumn sl + 1 }++stepColLoc :: Int -> SourceLocation -> SourceLocation+stepColLoc n sl = sl { slColumn = slColumn sl + n }++nextLineLoc :: SourceLocation -> SourceLocation+nextLineLoc sl = sl { slLine = slLine sl + 1, slColumn = 1 }++incrColState :: LexerState -> LexerState+incrColState ps = ps { psLocation = incrColLoc $ psLocation ps }++stepColState :: Int -> LexerState -> LexerState+stepColState n ps = ps { psLocation = stepColLoc n $ psLocation ps }++nextLineState :: LexerState -> LexerState+nextLineState ps = ps { psLocation = nextLineLoc $ psLocation ps }++stepLoc :: String -> SourceLocation -> SourceLocation+stepLoc [] loc = loc+stepLoc (x:xs) loc+  | x == '\n' = stepLoc xs (nextLineLoc loc)+  | otherwise = stepLoc xs (incrColLoc loc) -- assuming non-zero width characters++stepLocState :: String -> LexerState -> LexerState+stepLocState s ps = ps { psLocation = stepLoc s $ psLocation ps }++lastLexeme :: LexerState -> Maybe Lexeme+lastLexeme ps = case psSteps ps of+  ((_,t):_) -> Just t+  [] -> Nothing++stepReadSugarString :: String -> LexerState -> (String, LexerState)+stepReadSugarString s ps = case lastLexeme ps of+  Nothing -> stepReadSugarString' s ps Lexeme'Start -- Benign hack to start parsing+  Just t -> stepReadSugarString' s ps t++stepReadSugarString' :: String -> LexerState -> Lexeme -> (String, LexerState)+stepReadSugarString' [] ps _ = ([], ps)+stepReadSugarString' s ps t = case t of+  Lexeme'StringStart -> stepReadString s ps+  Lexeme'QuoteStart -> stepQuotedStart s ps+  Lexeme'QuotedString _ -> stepQuoteString s ps+  Lexeme'SingleLineComment -> stepSingleLineComment s ps+  Lexeme'MultiLineCommentStart -> stepMultiLineComment s ps+  _ -> normalStepReadSugarString s ps++normalStepReadSugarString :: String -> LexerState -> (String, LexerState)+normalStepReadSugarString [] ps = ([], ps)+normalStepReadSugarString s@(c:cs) ps+  | c == '\n' = (cs, nextLineState ps)+  | isSpace c = (cs, incrColState ps)+  | otherwise = case c of+    '{' -> (cs, step Lexeme'OpenCurl)+    '}' -> (cs, step Lexeme'CloseCurl)+    '(' -> (cs, step Lexeme'OpenParen)+    ')' -> (cs, step Lexeme'CloseParen)+    '[' -> (cs, step Lexeme'OpenSquare)+    ']' -> (cs, step Lexeme'CloseSquare)+    '<' -> (cs, step Lexeme'OpenAngle)+    '>' -> (cs, step Lexeme'CloseAngle)+    '"' -> (cs, step Lexeme'QuoteStart)+    ';' -> (cs, step Lexeme'SingleLineComment)+    _ -> case splitAtExactMay 2 s of+      Just ("#|", s') ->+        (s', stepColState 2 $ ps{psSteps = (psLocation ps, Lexeme'MultiLineCommentStart) : psSteps ps})+      _ -> (s, ps { psSteps = (psLocation ps, Lexeme'StringStart) : psSteps ps })+    where+      step t = (incrColState ps) { psSteps = (psLocation ps, t) : psSteps ps }++prependStep :: LexemeStep -> LexerState -> LexerState+prependStep s ps = ps { psSteps = s : psSteps ps }++stepReadString :: String -> LexerState -> (String, LexerState)+stepReadString s ps = (s', ps')+  where+    ps' = stepColState (length str) $ prependStep step ps+    step = (psLocation ps, Lexeme'String str)+    (str, s') = span2+      (\c c' -> not $ isSpace c || isReservedChar c || (c == '#' && c' == Just '|'))+      s++isReservedChar :: Char -> Bool+isReservedChar = flip elem reservedChars++span2 :: (a -> Maybe a -> Bool) -> [a] -> ([a],[a])+span2 _ [] = ([],[])+span2 f (x:[]) = if f x Nothing then ([x],[]) else ([],[x])+span2 f xs@(x:y:z)+  | f x (Just y) = let (ys,zs) = span2 f (y:z) in (x:ys, zs)+  | otherwise = ([], xs)++stepSingleLineComment :: String -> LexerState -> (String, LexerState)+stepSingleLineComment s ps = (s', ps')+  where+    ps' = stepColState (length str) $ prependStep step ps+    step = (psLocation ps, Lexeme'String str)+    (str, s') = span (/= '\n') s++stepMultiLineComment :: String -> LexerState -> (String, LexerState)+stepMultiLineComment s ps =  case span2ExactSkip (\c c' -> c == '|' && c' == '#') s of+  Nothing -> ("", stepLocState s ps) -- failed to consume end of comment marker+  Just (str, s') -> let+    step = (psLocation ps, Lexeme'MultiLineCommentEnd)+    ps' = stepLocState (str ++ "|#") $ prependStep step ps+    in (s', ps')++span2ExactSkip :: (a -> a -> Bool) -> [a] -> Maybe ([a], [a])+span2ExactSkip _ [] = Nothing+span2ExactSkip _ (_:[]) = Nothing+span2ExactSkip f (x:y:z)+  | f x y = Just ([], z)+  | otherwise = fmap (\(a,b) -> (x:a, b)) (span2ExactSkip f (y:z))++stepQuotedStart :: String -> LexerState -> (String, LexerState)+stepQuotedStart s ps = (s', ps')+  where+    ps' = stepColState (length str) $ prependStep step ps+    step = (loc, Lexeme'QuotedString str)+    (loc, str, s') = spanWithEscape (psLocation ps) s++spanWithEscape :: SourceLocation -> String -> (SourceLocation, String, String)+spanWithEscape loc [] = (loc, [],[])+spanWithEscape loc (x:[]) = if x == '"' then (incrColLoc loc, [],[x]) else (loc, [x],[])+spanWithEscape loc xs@(x:y:z) = case x of+  '"' -> (incrColLoc loc, [],xs)+  '\\' -> case spanWithEscape loc z of+    (loc', ys,zs) -> (incrColLoc loc', x:y:ys, zs)+  '\n' -> let (loc', ys,zs) = spanWithEscape loc (y:z) in (nextLineLoc loc', x:ys, zs)+  _ -> let (loc', ys,zs) = spanWithEscape loc (y:z) in (incrColLoc loc', x:ys, zs)++stepQuoteString :: String -> LexerState -> (String, LexerState)+stepQuoteString ('"':xs) ps = (xs, incrColState $ prependStep (psLocation ps, Lexeme'QuoteEnd) ps)+stepQuoteString xs ps = normalStepReadSugarString xs ps -- Something went wrong, but keep parsing.
+ src/Sugar/Parser.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP, NamedFieldPuns #-}+module Sugar.Parser+  ( Token(..)+  , TokenStep+  , TokenNote+  , ParseError+  , Parser(..)+  , flatten+  , sugarParse+  , sugarParseTopLevel+  , sugarParseMap+  , sugarParseList+  ) where++import Control.Monad+import Control.Applicative++import qualified Data.Text as T++import Sugar.Types+import Sugar.Lexer++data Token+  = Token'Unit TokenNote+  | Token'String String TokenNote+  | Token'List [TokenStep] Wrap TokenNote+  | Token'Map [(TokenStep,TokenStep)] TokenNote+  deriving (Show, Eq)++type TokenStep = (SourceLocation, Token)+type TokenNote = Maybe [TokenStep]+type ParseError = (Maybe SourceLocation, String)++newtype Parser a = Parser+  { runParser :: [LexemeStep] -> ([LexemeStep], Either ParseError a) }++instance Functor Parser where+  fmap f (Parser g) = Parser $ \ts -> let (ts', x) = g ts in (ts', fmap f x)++instance Applicative Parser where+  pure x = Parser $ \ts -> (ts, Right x)+  p <*> q = Parser $ \ts -> let (ts',x) = runParser p ts in case x of+    Left a -> (ts', Left a)+    Right b -> runParser (fmap b q) ts'++instance Alternative Parser where+  empty = Parser $ \ts -> (ts, Left (Nothing, ""))+  p1 <|> p2 = Parser $ \ts -> case runParser p1 ts of+    (ts', Left err)+      | ts' == ts   -> runParser p2 ts+      | otherwise -> (ts', Left err)+    success -> success++instance Monad Parser where+  (Parser p) >>= f = Parser $ \ts -> let (ts',x) = p ts in case x of+    Left a -> (ts', Left a)+    Right b -> runParser (f b) ts'++--++flatten :: TokenStep -> Sugar+flatten (_, s) = case s of+  Token'Unit note -> Sugar'Unit (fmap flatten <$> note)+  Token'String str note -> Sugar'Text (T.pack str) (fmap flatten <$> note)+  Token'List elems wrap note -> Sugar'List (flatten <$> elems) wrap (fmap flatten <$> note)+  Token'Map elems note -> Sugar'Map ((\(x,y) -> (flatten x, flatten y)) <$> elems) (fmap flatten <$> note)++--++sugarParse :: Parser TokenStep+sugarParse = do+  (loc, tkn) <- peek+  case tkn of+    Lexeme'Start -> sugarParse+    Lexeme'OpenCurl -> sugarParseMap+    Lexeme'OpenParen -> try sugarParseUnit <|> sugarParseParenList+    Lexeme'OpenSquare -> sugarParseSquareList+    Lexeme'QuoteStart -> sugarParseQuote+    Lexeme'StringStart -> sugarParseText+    Lexeme'SingleLineComment -> nextLexeme *> ignoreUntilNewLine loc *> sugarParse+    Lexeme'MultiLineCommentStart -> nextLexeme *> ignoreUntilMultilineCommentEnd 0 *> sugarParse+    _ -> sugarParseUnexpected (loc, tkn)++ignoreUntilNewLine :: SourceLocation -> Parser ()+ignoreUntilNewLine sl = do+  tkn' <- tryPeek+  case tkn' of+    Nothing -> return ()+    Just (loc,_) -> if slLine loc == slLine sl+      then nextLexeme *> ignoreUntilNewLine loc+      else return ()++ignoreUntilMultilineCommentEnd :: Int -> Parser ()+ignoreUntilMultilineCommentEnd nested = do+  tkn' <- tryPeek+  case tkn' of+    Nothing -> sugarParseExpected "`|#` to close multi-line comment"+    Just (_,Lexeme'MultiLineCommentStart) -> nextLexeme *> ignoreUntilMultilineCommentEnd (nested + 1)+    Just (_,Lexeme'MultiLineCommentEnd) -> do+      void nextLexeme+      when (nested > 0) $ ignoreUntilMultilineCommentEnd (nested - 1)+    Just (_,_) -> nextLexeme *> ignoreUntilMultilineCommentEnd nested++sugarParseUnexpected :: LexemeStep -> Parser TokenStep+sugarParseUnexpected (loc, tkn) = Parser $ \ts -> (ts, Left (Just loc, "Unexpected: " ++ show tkn))++sugarParseExpected :: String -> Parser ()+sugarParseExpected expected =  Parser $ \ts -> (ts, Left (Nothing, "Expected: " ++ expected))++sugarParseNote :: Parser (Maybe [TokenStep])+sugarParseNote = do+  tkn' <- tryPeek+  case tkn' of+    Nothing -> return Nothing+    Just (_,tkn) -> case tkn of+      Lexeme'OpenAngle -> fmap pure $ between (lexeme Lexeme'OpenAngle) (lexeme Lexeme'CloseAngle) (many sugarParse)+      _ -> pure Nothing++sugarParseUnit :: Parser TokenStep+sugarParseUnit = do+  (sl,  _) <- lexeme Lexeme'OpenParen+  (sl', _) <- lexeme Lexeme'CloseParen+  if slColumn sl + 1 ==  slColumn sl' -- no space between parens+    then do+      note <- sugarParseNote+      let tkn = Token'Unit note+      pure (sl, tkn)+    else+      empty++sugarParseTopLevel :: Parser TokenStep+sugarParseTopLevel = sugarParseTopLevelMap++sugarParseMap :: Parser TokenStep+sugarParseMap = do+  (sl, _) <- lexeme Lexeme'OpenCurl+  elems <- many ((,) <$> sugarParse <*> sugarParse)+  void $ lexeme Lexeme'CloseCurl+  note <- sugarParseNote+  let tkn = Token'Map elems note+  pure (sl, tkn)++sugarParseTopLevelMap :: Parser TokenStep+sugarParseTopLevelMap = do+  elems <- many ((,) <$> sugarParse <*> sugarParse)+  let tkn = Token'Map elems Nothing+  case elems of+    (((sl,_), _):_) -> return (sl, tkn)+    [] -> return (SourceLocation 0 0, tkn)++sugarParseList :: Parser TokenStep+sugarParseList = try sugarParseSquareList <|> sugarParseParenList++sugarParseSquareList :: Parser TokenStep+sugarParseSquareList = do+  (sl, _) <- lexeme Lexeme'OpenSquare+  elems <- many sugarParse+  void $ lexeme Lexeme'CloseSquare+  note <- sugarParseNote+  let tkn = Token'List elems Wrap'Square note+  pure (sl, tkn)++sugarParseParenList :: Parser TokenStep+sugarParseParenList = do+  (sl, _) <- lexeme Lexeme'OpenParen+  elems <- many sugarParse+  void $ lexeme Lexeme'CloseParen+  note <- sugarParseNote+  let tkn = Token'List elems Wrap'Paren note+  pure (sl, tkn)++sugarParseQuote :: Parser TokenStep+sugarParseQuote = do+  (sl, _) <- lexeme Lexeme'QuoteStart+  s <- lexemeQuoteString+  void $ lexeme Lexeme'QuoteEnd+  note <- sugarParseNote+  let tkn = Token'String s note+  pure (sl, tkn)++sugarParseText :: Parser TokenStep+sugarParseText = do+  (sl, _) <- lexeme Lexeme'StringStart+  s <- lexemeString+  note <- sugarParseNote+  let tkn = Token'String s note+  pure (sl, tkn)++lexemeQuoteString :: Parser String+lexemeQuoteString = Parser $ \ts -> case ts of+  [] -> (ts, Left (Nothing, "lexemeQuoteString end"))+  (x:xs) -> case snd x of+    Lexeme'QuotedString s -> (xs, Right s)+    _ -> (xs, Left (Just $ fst x, "lexemeQuoteString none"))++lexemeString :: Parser String+lexemeString = Parser $ \ts -> case ts of+  [] -> (ts, Left (Nothing, "lexemeString end"))+  (x:xs) -> case snd x of+    Lexeme'String s -> (xs, Right s)+    _ -> (xs, Left (Just $ fst x, "lexemeString none"))++lexeme :: Lexeme -> Parser LexemeStep+lexeme t = Parser $ \ts -> case ts of+  [] -> (ts, Left (Nothing, "lexeme none"))+  (x:xs) -> if t == (snd x) then (xs, Right x) else (xs, Left (Just $ fst x, "lexeme no match"))++peek :: Parser LexemeStep+peek = Parser $ \ts -> case ts of+  [] -> (ts, Left (Nothing, "peek"))+  (x:_) -> (ts, Right $ x)++tryPeek :: Parser (Maybe LexemeStep)+tryPeek = Parser $ \ts -> case ts of+  [] -> (ts, Right Nothing)+  (x:_) -> (ts, Right $ Just x)++nextLexeme :: Parser LexemeStep+nextLexeme = Parser $ \ts -> case ts of+  [] -> ([], Left (Nothing, "nextLexeme"))+  (x:xs) -> (xs, Right x)++between :: Applicative m => m open -> m close -> m a -> m a+between open close p = open *> p <* close++try :: Parser a -> Parser a+try p = Parser $ \ts -> case runParser p ts of+  (_, Left a) -> (ts, Left a)+  (ts', Right b)  -> (ts', Right b)++{-+parseError :: String -> String -> Parser a+parseError descr tag = Parser $ \ts -> case ts of+    [] -> (ts, Left $ (Nothing, msg))+    ((loc,_):_) -> (ts, Left $ (Just loc, msg))+  where+    msg = tag ++ ": " ++ descr++choice :: String -> [Parser a] -> Parser a+choice description = foldr (<|>) noMatch+  where noMatch = parseError description "no match"+-}
+ src/Sugar/TH.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP, TemplateHaskell #-}+module Sugar.TH where++-- import Sugar.Types+
+ src/Sugar/Types.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP #-}+module Sugar.Types+  ( Sugar(..)+  , Wrap(..)+  , Note+  , readSugarMay+  , sugarTextMay+  , sugarMapAsIxMap+  , reservedChars+  , FromSugar(..)+  , ToSugar(..)+  ) where++import Data.Text (Text)+import Data.Map (Map)+import Data.Maybe (mapMaybe)+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 GHC.Generics (Generic)+import Safe (readMay)++import qualified Data.Map as Map+import qualified Data.Serialize as Serialize+import qualified Data.Store as Store ()+import qualified Data.ByteString as BS+import qualified Data.Text as T++---++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]++--++sugarTextMay :: Sugar -> Maybe Text+sugarTextMay (Sugar'Text t _) = Just t+sugarTextMay _ = Nothing++readSugarMay :: Read a => Sugar -> Maybe a+readSugarMay (Sugar'Text t _) = readMay $ T.unpack t+readSugarMay _ = Nothing++sugarMapAsIxMap :: [(Sugar,Sugar)] -> Map (Int, Sugar) Sugar+sugarMapAsIxMap = Map.fromList . zipWith (\i (k,v) -> ((i,k),v)) [0..]++sugarShow :: Show a => a -> Sugar+sugarShow s = Sugar'Text (T.pack $ show s) Nothing++reservedChars :: [Char]+reservedChars = ['\"','[',']','<','>','(',')','{','}',';']++--++instance Ord Sugar where+  compare (Sugar'Unit x) (Sugar'Unit y) = compare x y+  compare Sugar'Unit{} _ = GT+  compare _ Sugar'Unit{} = LT+  compare (Sugar'Text x0 x1) (Sugar'Text y0 y1) = compare x0 y0 `mappend` compare x1 y1+  compare Sugar'Text{} _ = GT+  compare _ Sugar'Text{} = LT+  compare (Sugar'List x0 _ x1) (Sugar'List y0 _ y1) = compare x0 y0 `mappend` compare x1 y1+  compare Sugar'List{} _ = GT+  compare _ Sugar'List{} = LT+  compare (Sugar'Map x0 x1) (Sugar'Map y0 y1) = compare x0 y0 `mappend` compare x1 y1++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++instance FromSugar a => FromSugar (Maybe a) where+  parseSugar (Sugar'Unit _) = Just Nothing+  parseSugar s = (return . Just) =<< parseSugar s++instance (FromSugar a, Ord a, FromSugar b) => FromSugar (Map a b) where+  parseSugar (Sugar'Map m _) = Just $ Map.fromList $+    mapMaybe+      (\(s,v) -> (,) <$> parseSugar s <*> parseSugar v)+      m+  parseSugar _ = Nothing++instance FromSugar Text where+  parseSugar (Sugar'Text t _) = Just t+  parseSugar _ = Nothing++instance FromSugar Bool where+  parseSugar (Sugar'Text "#t" _) = Just True+  parseSugar (Sugar'Text "#f" _) = Just False+  parseSugar _ = Nothing++instance FromSugar Integer where parseSugar = readSugarMay+instance FromSugar Int where parseSugar = readSugarMay+instance FromSugar Int8 where parseSugar = readSugarMay+instance FromSugar Int16 where parseSugar = readSugarMay+instance FromSugar Int32 where parseSugar = readSugarMay+instance FromSugar Int64 where parseSugar = readSugarMay+instance FromSugar Word where parseSugar = readSugarMay+instance FromSugar Word8 where parseSugar = readSugarMay+instance FromSugar Word16 where parseSugar = readSugarMay+instance FromSugar Word32 where parseSugar = readSugarMay+instance FromSugar Word64 where parseSugar = readSugarMay+instance FromSugar Float where parseSugar = readSugarMay+instance FromSugar Double where parseSugar = readSugarMay+++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: Will conflict with a String instance (aka [Char])+instance ToSugar a => ToSugar [a] where+  toSugar xs = Sugar'List (map toSugar xs) Wrap'Square Nothing++instance ToSugar a => ToSugar (Maybe a) where+  toSugar Nothing = Sugar'Unit Nothing+  toSugar (Just a) = toSugar a++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 Bool where+  toSugar s = toSugar (if s then "#t" else "#f" :: Text)++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
sugar.cabal view
@@ -1,13 +1,13 @@ name: sugar-version: 0.0.0.1-synopsis: Legible data+version: 0.0.1+synopsis: A general purpose data language for humans. homepage: https://github.com/jxv/sugar#readme-description: Please see the README on GitHub at <https://github.com/jxv/sugar#readme>+description: Alternative to: JSON, YAML, TOML, et cetera. 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: OtherLicense license-file: LICENSE build-type: Simple cabal-version: 1.14@@ -23,6 +23,11 @@ library   exposed-modules:       Sugar+      Sugar.Types+      Sugar.IO+      Sugar.Parser+      Sugar.Lexer+      Sugar.TH   hs-source-dirs:       src   default-extensions:@@ -31,8 +36,8 @@       base >=4.7 && <5     , bytestring     , cereal+    , store     , containers >0.5 && <1-    , megaparsec     , ordered-containers     , safe     , text@@ -41,15 +46,18 @@     , vector   default-language: Haskell2010 -test-suite sugar-test-suite+test-suite sugar-tests   type: exitcode-stdio-1.0   main-is: Main.hs   hs-source-dirs:-      test-suite+      tests   ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N   build-depends:       base+    , file-embed+    , hspec     , sugar     , tasty     , tasty-hspec+    , text   default-language: Haskell2010
− test-suite/Main.hs 
@@ -1,59 +0,0 @@-{-# 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
+ tests/Main.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP, TemplateHaskell #-}++import qualified Test.Tasty+import Data.Text.Encoding (decodeUtf8)+import Test.Tasty.Hspec+import Test.Hspec+import Data.FileEmbed (embedFile)++import Sugar++main :: IO ()+main = do+  test <- testSpec "sugar" spec+  Test.Tasty.defaultMain test++spec :: Spec+spec = parallel $ do+  it "unit" $ do+    let actual = map snd $ psSteps $ sugarLexerState "()"+    let expected = [Lexeme'OpenParen, Lexeme'CloseParen]+    actual `shouldBe` expected+  it "string" $ do+    let actual = map snd $ psSteps $ sugarLexerState "hello"+    let expected = [Lexeme'StringStart, Lexeme'String "hello"]+    actual `shouldBe` expected+  it "empty map" $ do+    let actual = map snd $ psSteps $ sugarLexerState "{}"+    let expected = [Lexeme'OpenCurl, Lexeme'CloseCurl]+    actual `shouldBe` expected+  it "list" $ do+    let actual = map snd $ psSteps $ sugarLexerState "[]"+    let expected = [Lexeme'OpenSquare, Lexeme'CloseSquare]+    actual `shouldBe` expected+  it "angle" $ do+    let actual = map snd $ psSteps $ sugarLexerState "<>"+    let expected = [Lexeme'OpenAngle, Lexeme'CloseAngle]+    actual `shouldBe` expected+  it "Example 01 Top Level Map" $ do+    let actual = parseSugarFromText $ decodeUtf8 $(embedFile "../examples/01_top-level-map.sg")+    let expected = Just $ Sugar'Map+          [(Sugar'Text "Lorem" Nothing,Sugar'Text "ipsum" Nothing)+          ,(Sugar'Text "dolor" Nothing,Sugar'Text "site amet" Nothing)+          ,(Sugar'Text "consectetur adipiscing" Nothing,Sugar'Text "elit" Nothing)+          ,(Sugar'Text "sed do" Nothing,Sugar'Text "eiusmod tempor" Nothing)+          ]+          Nothing+    actual `shouldBe` expected+  it "Example 02 Nested Map" $ do+    let actual = parseSugarFromText $ decodeUtf8 $(embedFile "../examples/02_nested-map.sg")+    let expected = Just $ Sugar'Map+          [(Sugar'Text "Lorem" Nothing,Sugar'Map+            [(Sugar'Text "ipsum" Nothing,Sugar'Text "dolor" Nothing)+            ,(Sugar'Text "site" Nothing,Sugar'Text "amet consectetur" Nothing)+            ,(Sugar'Text "adipiscing elit" Nothing,Sugar'Text "sed" Nothing)+            ,(Sugar'Text "do eiusmod" Nothing,Sugar'Text "tempor incididunt" Nothing)+            ] Nothing)+          ,(Sugar'Text "ut labore" Nothing,Sugar'Map+            [(Sugar'Text "et" Nothing,Sugar'Text "dolore" Nothing)+            ,(Sugar'Text "manga" Nothing,Sugar'Text "aliqua ut" Nothing)+            ,(Sugar'Text "enium ad" Nothing,Sugar'Text "minim" Nothing)+            ,(Sugar'Text "veniam quis" Nothing,Sugar'Text "nostrud exercitation" Nothing)+            ] Nothing)+          ]+          Nothing+    actual `shouldBe` expected+  it "Example 03 Top Level List" $ do+    let actual = parseSugarListFromText $ decodeUtf8 $(embedFile "../examples/03_top-level-list.sg")+    let expected = Just $ Sugar'List+          [Sugar'Text "Lorem" Nothing+          ,Sugar'Text "ipsum" Nothing+          ,Sugar'Text "dolor site" Nothing+          ,Sugar'Map+            [(Sugar'Text "amet" Nothing,Sugar'Text "consectetur" Nothing)]+            Nothing+          ]+          Wrap'Square+          Nothing+    actual `shouldBe` expected+  it "Example 04 Nest List" $ do+    let actual = parseSugarListFromText $ decodeUtf8 $(embedFile "../examples/04_nest-list.sg")+    let expected = Just $ Sugar'List+          [Sugar'List+            [Sugar'Text "Lorem" Nothing,Sugar'Text "ipsum" Nothing]+            Wrap'Square+            Nothing+          ,Sugar'List+            [Sugar'Text "ipsum" Nothing+            ,Sugar'List+              [Sugar'Text "dolor site" Nothing+              ,Sugar'Map+                [(Sugar'Text "amet" Nothing,Sugar'Text "consectetur" Nothing)] Nothing+              ]+              Wrap'Square+              Nothing+            ]+            Wrap'Square+            Nothing+          ]+          Wrap'Square+          Nothing+    actual `shouldBe` expected+  it "Example 05 Note" $ do+    let actual = parseSugarFromText $ decodeUtf8 $(embedFile "../examples/05_note.sg")+    let expected = Just $ Sugar'Map+          [(Sugar'Text "Lorem" Nothing,Sugar'Text "ipsum" (Just [Sugar'Text "dolor" Nothing]))+          ,(Sugar'Text "site" Nothing,Sugar'Text "amet" (Just [Sugar'Text "consectetur adipiscing" Nothing]))+          ,(Sugar'Map+            [(Sugar'Text "elit" Nothing,Sugar'Map+              [(Sugar'Text "sed" Nothing,Sugar'Text "do" Nothing)]+              (Just [Sugar'Text "eiusmod" Nothing]))+            ]+            (Just [Sugar'Text "tempor" Nothing])+          ,Sugar'List+            [Sugar'Text "incididunt" Nothing+            ,Sugar'Text "ut" (Just [Sugar'Text "labore" Nothing])+            ,Sugar'Text "et" (Just [Sugar'Text "dolore" Nothing,Sugar'Text "magna" Nothing])+            ]+            Wrap'Square+            (Just [Sugar'List [] Wrap'Square Nothing]))+          ]+          Nothing+    actual `shouldBe` expected+  it "Example 06 Top Level Non-Text Map" $ do+    let actual = parseSugarFromText $ decodeUtf8 $(embedFile "../examples/06_top-level-non-text-map.sg")+    let expected = Just $ Sugar'Map+          [+            (Sugar'Map+              [(Sugar'Text "first-name" Nothing,Sugar'Text "last-name" Nothing)]+              Nothing+            ,Sugar'Text "person" Nothing)+          , (Sugar'List+              [Sugar'Text "a" Nothing,Sugar'Text "b" Nothing,Sugar'Text "c" Nothing,Sugar'Text "d" Nothing,Sugar'Text "id" Nothing]+              Wrap'Square+              Nothing+            ,Sugar'Text "value" Nothing)+          ,(Sugar'Map+            [(Sugar'Text "nested" Nothing,+              Sugar'Map [(Sugar'Text "ident" Nothing,Sugar'Text "ifier" Nothing)] Nothing)] Nothing+            ,Sugar'Map+              [ (Sugar'Text "with" Nothing+                ,Sugar'Map+                  [(Sugar'Text "nested" Nothing,Sugar'Text "value-pair" Nothing)]+                  Nothing)+              ]+            Nothing)+          ]+          Nothing+    actual `shouldBe` expected+  it "Example 07 Comments" $ do+    let actual = parseSugarFromText $ decodeUtf8 $(embedFile "../examples/07_comments.sg")+    let expected = Just $ Sugar'Map+          [(Sugar'Text "a" Nothing,Sugar'Text "b" Nothing)+          ,(Sugar'Text "c" Nothing,Sugar'Text "d" Nothing)+          ,(Sugar'Text "e" Nothing,Sugar'Text "f" Nothing)+          ,(Sugar'Text "g" Nothing,Sugar'Text "h" Nothing)+          ]+          Nothing+    actual `shouldBe` expected