module Data.Syntax.Pretty (
Printer(..)
) where
import Control.Applicative
import Control.Lens.SemiIso
import Control.Monad
import Data.Monoid
import Data.SemiIsoFunctor
import Data.Syntax
import Data.Syntax.Char
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.PrettyPrint as P
newtype Printer a = Printer {
runPrinter :: a -> Either String P.Doc
}
instance SemiIsoFunctor Printer where
simap ai (Printer f) = Printer (apply ai >=> f)
instance SemiIsoApply Printer where
sipure ai = Printer (\a -> either Left (\_ -> Right mempty) (apply ai a))
(Printer f) /*/ (Printer g) = Printer (\(a, b) -> (<>) <$> f a <*> g b)
instance SemiIsoAlternative Printer where
siempty = Printer (\_ -> Left "error")
(Printer f) /|/ (Printer g) = Printer (\a -> f a <|> g a)
instance SemiIsoMonad Printer where
(Printer f) //= g = Printer (\(a, b) -> (<>) <$> f a <*> runPrinter (g a) b)
instance SemiIsoFix Printer where
sifix f = Printer $ \a -> runPrinter (f a) a
printText :: Text -> Either String P.Doc
printText = Right . P.text . T.unpack
instance Syntax Printer Text where
anyChar = Printer (Right . P.char)
take n = Printer (printText . T.take n)
takeWhile p = Printer (printText . T.takeWhile p)
takeWhile1 p = Printer (printText <=< notNull . T.takeWhile p)
where notNull t | T.null t = Left "takeWhile1: failed"
| otherwise = Right t
takeTill1 p = Printer (printText <=< notNull . T.takeWhile p)
where notNull t | T.null t = Left "takeTill1: failed"
| otherwise = Right t
instance SyntaxChar Printer Text where
decimal = Printer (format . toInteger)
where format i | i < 0 = Left "decimal: negative number"
| otherwise = Right (P.integer i)
scientific = Printer (Right . P.text . show)