196 lines
5.8 KiB
Haskell
196 lines
5.8 KiB
Haskell
module Gyehoek.Sexp.Grammar
|
|
( module Gyehoek.Sexp.Grammar.Base
|
|
, module Data.InvertibleGrammar.Combinators
|
|
, (>>>)
|
|
, toDatum
|
|
, fromDatum
|
|
, toData
|
|
, fromData
|
|
, encodeWith
|
|
, encodeWith'
|
|
, encodeDataWith
|
|
, decodeWith
|
|
, encodeTest
|
|
, encodeTestColour
|
|
, encodeDataTest
|
|
, encodeDataTestColour
|
|
, encodeOrShow'
|
|
, encodeOrShowData'
|
|
, decodeDataWith
|
|
, encodeDataWith'
|
|
, decodeTest
|
|
, decodeDataTest
|
|
, DataIso(..)
|
|
, DatumIso(..)
|
|
-- * generics
|
|
, with
|
|
, match
|
|
, Coproduct(..)
|
|
, fromDatumUnsafe
|
|
, Control.Category.id
|
|
, fromDataUnsafe
|
|
, writeDatum
|
|
, writeData
|
|
)
|
|
where
|
|
|
|
import Gyehoek.Sexp.Grammar.Base
|
|
import Gyehoek.Prelude hiding (snoc, Iso, flipped, cons, traversed, iso)
|
|
import Data.InvertibleGrammar (backward, sealed, forward, runGrammar)
|
|
import Gyehoek.Sexp.Print (printDatum, printDatum', printData, printData')
|
|
import Gyehoek.Jalmot
|
|
import Data.InvertibleGrammar.Combinators
|
|
import qualified Gyehoek.Sexp.Read as Read
|
|
import qualified Data.Text.IO as TIO
|
|
import Text.Pretty.Simple (pPrintNoColor)
|
|
import Data.InvertibleGrammar.Generic
|
|
import qualified Control.Category
|
|
import qualified Data.Vector as V
|
|
import Data.String (IsString (fromString))
|
|
import qualified Data.Text as T
|
|
import System.Environment (lookupEnv)
|
|
import Data.Foldable (toList)
|
|
|
|
|
|
toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
|
|
toDatum g =
|
|
backward (sealed g)
|
|
>>> runGrammar noAnn
|
|
>>> either (throwError . GrammarError) pure
|
|
|
|
toData :: Jalmot :> es => DataGrammar a -> a -> Eff es (List Datum)
|
|
toData g =
|
|
backward (sealed g)
|
|
>>> runGrammar noAnn
|
|
>>> either (throwError . GrammarError) pure
|
|
|
|
fromDatum :: (HasCallStack, Jalmot :> es) => DatumGrammar a -> Datum -> Eff es a
|
|
fromDatum g =
|
|
forward (sealed g)
|
|
>>> runGrammar noAnn
|
|
>>> either (throwError . GrammarError) pure
|
|
|
|
fromDatumUnsafe :: HasCallStack => DatumGrammar a -> Datum -> a
|
|
fromDatumUnsafe g = runJalmotUnsafe . fromDatum g
|
|
|
|
fromDataUnsafe :: HasCallStack => DataGrammar a -> List Datum -> a
|
|
fromDataUnsafe g = runJalmotUnsafe . fromData g
|
|
|
|
fromData
|
|
:: (HasCallStack, Jalmot :> es)
|
|
=> DataGrammar a -> List Datum -> Eff es a
|
|
fromData g =
|
|
forward (sealed g)
|
|
>>> runGrammar noAnn
|
|
>>> either (throwError . GrammarError) pure
|
|
|
|
encodeWith :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
|
|
encodeWith g = toDatum g >>> fmap printDatum
|
|
|
|
encodeDataWith :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
|
|
encodeDataWith g = toData g >>> fmap printData
|
|
|
|
encodeDataWith' :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
|
|
encodeDataWith' g = toData g >>> fmap printData'
|
|
|
|
encodeWith' :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
|
|
encodeWith' g = toDatum g >>> fmap printDatum'
|
|
|
|
decodeWith :: forall es a. Jalmot :> es => DatumGrammar a -> Text -> Eff es a
|
|
decodeWith g = Read.readString1 @es >=> fromDatum g
|
|
|
|
decodeDataWith
|
|
:: forall es a. Jalmot :> es => DataGrammar a -> Text -> Eff es a
|
|
decodeDataWith g = Read.readString @es >=> fromData g
|
|
|
|
-- | run a grammar, quick and dirty.
|
|
decodeTest :: Show a => DatumGrammar a -> Text -> IO ()
|
|
decodeTest g = pPrintNoColor <=< (runJalmotIO . decodeWith g)
|
|
|
|
-- | run a grammar, quick and dirty.
|
|
encodeTest :: DatumGrammar a -> a -> IO ()
|
|
encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g)
|
|
|
|
-- | run a grammar, quick and dirty.
|
|
encodeTestColour :: DatumGrammar a -> a -> IO ()
|
|
encodeTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeWith g)
|
|
|
|
encodeDataTest :: DataGrammar a -> a -> IO ()
|
|
encodeDataTest g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith' g)
|
|
|
|
encodeDataTestColour :: DataGrammar a -> a -> IO ()
|
|
encodeDataTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith g)
|
|
|
|
-- | run a grammar, quick and dirty.
|
|
decodeDataTest :: Show a => DataGrammar a -> Text -> IO ()
|
|
decodeDataTest g = pPrintNoColor <=< (runJalmotIO . decodeDataWith g)
|
|
|
|
encodeOrShow' :: (IsString s, Show a) => DatumGrammar a -> a -> s
|
|
encodeOrShow' g x = fromString $
|
|
case runPureEff . runJalmot . encodeWith' g $ x of
|
|
Left _ -> show x
|
|
Right t -> T.unpack t
|
|
|
|
encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
|
|
encodeOrShow g x = fromString $
|
|
case runPureEff . runJalmot . encodeWith g $ x of
|
|
Left _ -> show x
|
|
Right t -> T.unpack t
|
|
|
|
encodeOrShowData' :: (IsString s, Show a) => DataGrammar a -> a -> s
|
|
encodeOrShowData' g x = fromString $
|
|
case runPureEff . runJalmot . encodeDataWith' g $ x of
|
|
Left _ -> show x
|
|
Right t -> T.unpack t
|
|
|
|
encodeOrShowData :: (IsString s, Show a) => DataGrammar a -> a -> s
|
|
encodeOrShowData g x = fromString $
|
|
case runPureEff . runJalmot . encodeDataWith g $ x of
|
|
Left _ -> show x
|
|
Right t -> T.unpack t
|
|
|
|
useColour :: IO Bool
|
|
useColour = maybe True (const False) <$> lookupEnv "NO_COLOR"
|
|
|
|
writeDatum :: (Show a, DatumIso a, MonadIO m) => a -> m ()
|
|
writeDatum x = do
|
|
c <- liftIO useColour
|
|
let f = if c then encodeOrShow else encodeOrShow'
|
|
liftIO . TIO.putStrLn . f datumIso $ x
|
|
|
|
writeData :: (Show a, DataIso a, MonadIO m) => a -> m ()
|
|
writeData x = do
|
|
c <- liftIO useColour
|
|
let f = if c then encodeOrShowData else encodeOrShowData'
|
|
liftIO . TIO.putStrLn . f dataIso $ x
|
|
|
|
class DatumIso a where
|
|
datumIso :: DatumGrammar a
|
|
|
|
class DataIso a where
|
|
dataIso :: DataGrammar a
|
|
|
|
|
|
|
|
instance DatumIso a => DatumIso (List a) where
|
|
datumIso = list $ rest datumIso
|
|
|
|
instance DatumIso Bool where datumIso = boolean
|
|
|
|
instance DatumIso Int where datumIso = int
|
|
|
|
instance DatumIso Datum where datumIso = Control.Category.id
|
|
|
|
instance DatumIso a => DataIso (List a) where
|
|
dataIso = onHead . traversed . sealed $ datumIso @a
|
|
|
|
instance DatumIso a => DataIso (V.Vector a) where
|
|
dataIso = iso fromList V.toList
|
|
>>> (onHead . traversed . sealed $ datumIso @a)
|
|
|
|
instance DatumIso a => DataIso (NonEmpty a) where
|
|
dataIso = nonEmptyData datumIso
|
|
|
|
instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
|
|
datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2
|