{-# 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