{-# 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
{ PrettyPrintConfig -> Int
ppcTabbedSpaces :: Int
} deriving (Int -> PrettyPrintConfig -> ShowS
[PrettyPrintConfig] -> ShowS
PrettyPrintConfig -> String
(Int -> PrettyPrintConfig -> ShowS)
-> (PrettyPrintConfig -> String)
-> ([PrettyPrintConfig] -> ShowS)
-> Show PrettyPrintConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrettyPrintConfig] -> ShowS
$cshowList :: [PrettyPrintConfig] -> ShowS
show :: PrettyPrintConfig -> String
$cshow :: PrettyPrintConfig -> String
showsPrec :: Int -> PrettyPrintConfig -> ShowS
$cshowsPrec :: Int -> PrettyPrintConfig -> ShowS
Show, PrettyPrintConfig -> PrettyPrintConfig -> Bool
(PrettyPrintConfig -> PrettyPrintConfig -> Bool)
-> (PrettyPrintConfig -> PrettyPrintConfig -> Bool)
-> Eq PrettyPrintConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrettyPrintConfig -> PrettyPrintConfig -> Bool
$c/= :: PrettyPrintConfig -> PrettyPrintConfig -> Bool
== :: PrettyPrintConfig -> PrettyPrintConfig -> Bool
$c== :: PrettyPrintConfig -> PrettyPrintConfig -> Bool
Eq)
data PrettyPrintState = PrettyPrintState
{ PrettyPrintState -> Int
ppsNesting :: Int
} deriving (Int -> PrettyPrintState -> ShowS
[PrettyPrintState] -> ShowS
PrettyPrintState -> String
(Int -> PrettyPrintState -> ShowS)
-> (PrettyPrintState -> String)
-> ([PrettyPrintState] -> ShowS)
-> Show PrettyPrintState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrettyPrintState] -> ShowS
$cshowList :: [PrettyPrintState] -> ShowS
show :: PrettyPrintState -> String
$cshow :: PrettyPrintState -> String
showsPrec :: Int -> PrettyPrintState -> ShowS
$cshowsPrec :: Int -> PrettyPrintState -> ShowS
Show, PrettyPrintState -> PrettyPrintState -> Bool
(PrettyPrintState -> PrettyPrintState -> Bool)
-> (PrettyPrintState -> PrettyPrintState -> Bool)
-> Eq PrettyPrintState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrettyPrintState -> PrettyPrintState -> Bool
$c/= :: PrettyPrintState -> PrettyPrintState -> Bool
== :: PrettyPrintState -> PrettyPrintState -> Bool
$c== :: PrettyPrintState -> PrettyPrintState -> Bool
Eq)
prettyPrintSugarIO :: Sugar -> IO ()
prettyPrintSugarIO :: Sugar -> IO ()
prettyPrintSugarIO = Text -> IO ()
TIO.putStr (Text -> IO ()) -> (Sugar -> Text) -> Sugar -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sugar -> Text
prettyPrintSugar
prettyPrintSugar :: Sugar -> Text
prettyPrintSugar :: Sugar -> Text
prettyPrintSugar = PrettyPrintConfig -> Sugar -> Text
prettyPrintSugar' (Int -> PrettyPrintConfig
PrettyPrintConfig Int
2)
prettyPrintSugar' :: PrettyPrintConfig -> Sugar -> Text
prettyPrintSugar' :: PrettyPrintConfig -> Sugar -> Text
prettyPrintSugar' PrettyPrintConfig
ppc = PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep PrettyPrintConfig
ppc (Int -> PrettyPrintState
PrettyPrintState Int
0)
prettyPrintNesting :: PrettyPrintConfig -> PrettyPrintState -> Text
prettyPrintNesting :: PrettyPrintConfig -> PrettyPrintState -> Text
prettyPrintNesting PrettyPrintConfig
ppc PrettyPrintState
pps = Int -> Text -> Text
T.replicate (PrettyPrintConfig -> Int
ppcTabbedSpaces PrettyPrintConfig
ppc Int -> Int -> Int
forall a. Num a => a -> a -> a
* PrettyPrintState -> Int
ppsNesting PrettyPrintState
pps) Text
" "
ppsIncrNesting :: PrettyPrintState -> PrettyPrintState
ppsIncrNesting :: PrettyPrintState -> PrettyPrintState
ppsIncrNesting PrettyPrintState
pps = PrettyPrintState
pps { ppsNesting :: Int
ppsNesting = PrettyPrintState -> Int
ppsNesting PrettyPrintState
pps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
ppsDecrNesting :: PrettyPrintState -> PrettyPrintState
ppsDecrNesting :: PrettyPrintState -> PrettyPrintState
ppsDecrNesting PrettyPrintState
pps = PrettyPrintState
pps { ppsNesting :: Int
ppsNesting = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 then Int
n else Int
0 }
where
n :: Int
n = PrettyPrintState -> Int
ppsNesting PrettyPrintState
pps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
ppNewLine :: PrettyPrintConfig -> PrettyPrintState -> Text
ppNewLine :: PrettyPrintConfig -> PrettyPrintState -> Text
ppNewLine PrettyPrintConfig
ppc PrettyPrintState
pps = Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PrettyPrintConfig -> PrettyPrintState -> Text
prettyPrintNesting PrettyPrintConfig
ppc PrettyPrintState
pps
prettyPrintStep :: PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep :: PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep PrettyPrintConfig
_ PrettyPrintState
_ (Sugar'Unit Note
note) = Text
"()" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
prettyPrintStep PrettyPrintConfig
_ PrettyPrintState
_ (Sugar'Text Text
txt Note
note) = Text -> Text
sanitizeText Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
prettyPrintStep PrettyPrintConfig
ppc PrettyPrintState
pps (Sugar'List [Sugar]
xs Wrap
w Note
note) =
Text
open
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat ((Sugar -> Text) -> [Sugar] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Sugar
x -> [Text] -> Text
T.concat [PrettyPrintConfig -> PrettyPrintState -> Text
ppNewLine PrettyPrintConfig
ppc PrettyPrintState
pps, PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep PrettyPrintConfig
ppc (PrettyPrintState -> PrettyPrintState
ppsIncrNesting PrettyPrintState
pps) Sugar
x]) [Sugar]
xs)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PrettyPrintConfig -> PrettyPrintState -> Text
ppNewLine PrettyPrintConfig
ppc (PrettyPrintState -> PrettyPrintState
ppsDecrNesting PrettyPrintState
pps)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
close
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
where
open, close :: Text
(Text
open,Text
close) = case Wrap
w of Wrap
Wrap'Square -> (Text
"[",Text
"]"); Wrap
Wrap'Paren -> (Text
"(",Text
")")
prettyPrintStep PrettyPrintConfig
ppc PrettyPrintState
pps (Sugar'Map [(Sugar, Sugar)]
m Note
note) = if PrettyPrintState -> Int
ppsNesting PrettyPrintState
pps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Note -> Bool
forall a. Maybe a -> Bool
isNothing Note
note then Text
topLevel else Text
nested
where
topLevel :: Text
topLevel =
[Text] -> Text
T.concat (((Sugar, Sugar) -> Text) -> [(Sugar, Sugar)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Sugar
k,Sugar
v) -> [Text] -> Text
T.concat [PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep PrettyPrintConfig
ppc PrettyPrintState
nextPps Sugar
k, Text
" ", PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep PrettyPrintConfig
ppc PrettyPrintState
nextPps Sugar
v, Text
"\n"]) [(Sugar, Sugar)]
m)
nested :: Text
nested =
Text
"{"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (((Sugar, Sugar) -> Text) -> [(Sugar, Sugar)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Sugar
k,Sugar
v) -> [Text] -> Text
T.concat [PrettyPrintConfig -> PrettyPrintState -> Text
ppNewLine PrettyPrintConfig
ppc PrettyPrintState
pps, PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep PrettyPrintConfig
ppc PrettyPrintState
nextPps Sugar
k, Text
" ", PrettyPrintConfig -> PrettyPrintState -> Sugar -> Text
prettyPrintStep PrettyPrintConfig
ppc PrettyPrintState
nextPps Sugar
v]) [(Sugar, Sugar)]
m)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PrettyPrintConfig -> PrettyPrintState -> Text
ppNewLine PrettyPrintConfig
ppc (PrettyPrintState -> PrettyPrintState
ppsDecrNesting PrettyPrintState
pps)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
nextPps :: PrettyPrintState
nextPps = PrettyPrintState -> PrettyPrintState
ppsIncrNesting PrettyPrintState
pps
minifyPrint :: Sugar -> Text
minifyPrint :: Sugar -> Text
minifyPrint (Sugar'Unit Note
note) = Text
"()" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
minifyPrint (Sugar'Text Text
txt Note
note) = Text -> Text
sanitizeText Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
minifyPrint (Sugar'List [Sugar]
xs Wrap
w Note
note) = Text
open Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " ((Sugar -> Text) -> [Sugar] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Sugar -> Text
minifyPrint [Sugar]
xs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
close Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
where
open, close :: Text
(Text
open,Text
close) = case Wrap
w of Wrap
Wrap'Square -> (Text
"[",Text
"]"); Wrap
Wrap'Paren -> (Text
"(",Text
")")
minifyPrint (Sugar'Map [(Sugar, Sugar)]
m Note
note) = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " ((Sugar -> Text) -> [Sugar] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Sugar -> Text
minifyPrint [Sugar]
xs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note -> Text
minifyPrintNote Note
note
where
xs :: [Sugar]
xs :: [Sugar]
xs = (\(Sugar
k,Sugar
v) -> [Sugar
k,Sugar
v]) ((Sugar, Sugar) -> [Sugar]) -> [(Sugar, Sugar)] -> [Sugar]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Sugar, Sugar)]
m
minifyPrintNote :: Note -> Text
minifyPrintNote :: Note -> Text
minifyPrintNote Note
Nothing = Text
""
minifyPrintNote (Just [Sugar]
xs) = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " ((Sugar -> Text) -> [Sugar] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Sugar -> Text
minifyPrint [Sugar]
xs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
sanitizeText :: Text -> Text
sanitizeText :: Text -> Text
sanitizeText Text
t
| Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Text
"\"\""
| (Char -> Bool) -> Text -> Maybe Char
T.find (\Char
c -> Char -> Bool
isSeparator Char
c Bool -> Bool -> Bool
|| Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
reservedChars) Text
t Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Char
forall a. Maybe a
Nothing = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
replaceDoubleQuotes Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
| Bool
otherwise = Text
t
where
replaceDoubleQuotes :: Text -> Text
replaceDoubleQuotes :: Text -> Text
replaceDoubleQuotes = Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"\\\""
readSugarFromFile :: FilePath -> IO (Maybe Sugar)
readSugarFromFile :: String -> IO (Maybe Sugar)
readSugarFromFile String
path = do
Text
content <- String -> IO Text
TIO.readFile String
path
Maybe Sugar -> IO (Maybe Sugar)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Sugar -> IO (Maybe Sugar))
-> Maybe Sugar -> IO (Maybe Sugar)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Sugar
parseSugarFromText Text
content
parseSugarFromText :: Text -> Maybe Sugar
parseSugarFromText :: Text -> Maybe Sugar
parseSugarFromText Text
t = case Parser TokenStep
-> [LexemeStep] -> ([LexemeStep], Either ParseError TokenStep)
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser Parser TokenStep
sugarParseTopLevel (LexerState -> [LexemeStep]
psSteps (LexerState -> [LexemeStep]) -> LexerState -> [LexemeStep]
forall a b. (a -> b) -> a -> b
$ String -> LexerState
sugarLexerState (Text -> String
T.unpack Text
t)) of
([LexemeStep]
_, Left ParseError
_) -> Maybe Sugar
forall a. Maybe a
Nothing
([LexemeStep]
_, Right TokenStep
s) -> Sugar -> Maybe Sugar
forall a. a -> Maybe a
Just (Sugar -> Maybe Sugar) -> Sugar -> Maybe Sugar
forall a b. (a -> b) -> a -> b
$ TokenStep -> Sugar
flatten TokenStep
s
readSugarListFromFile :: FilePath -> IO (Maybe Sugar)
readSugarListFromFile :: String -> IO (Maybe Sugar)
readSugarListFromFile String
path = do
Text
content <- String -> IO Text
TIO.readFile String
path
Maybe Sugar -> IO (Maybe Sugar)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Sugar -> IO (Maybe Sugar))
-> Maybe Sugar -> IO (Maybe Sugar)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Sugar
parseSugarListFromText Text
content
parseSugarListFromText :: Text -> Maybe Sugar
parseSugarListFromText :: Text -> Maybe Sugar
parseSugarListFromText Text
t = case Parser TokenStep
-> [LexemeStep] -> ([LexemeStep], Either ParseError TokenStep)
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser Parser TokenStep
sugarParseList (LexerState -> [LexemeStep]
psSteps (LexerState -> [LexemeStep]) -> LexerState -> [LexemeStep]
forall a b. (a -> b) -> a -> b
$ String -> LexerState
sugarLexerState (Text -> String
T.unpack Text
t)) of
([LexemeStep]
_, Left ParseError
_) -> Maybe Sugar
forall a. Maybe a
Nothing
([LexemeStep]
_, Right TokenStep
s) -> Sugar -> Maybe Sugar
forall a. a -> Maybe a
Just (Sugar -> Maybe Sugar) -> Sugar -> Maybe Sugar
forall a b. (a -> b) -> a -> b
$ TokenStep -> Sugar
flatten TokenStep
s