module Present
(Presentation(..)
,ID
,present
,asData)
where
import qualified Present.ByteString as P
import Present.ID (ID)
import qualified Present.ID as ID
import qualified Present.String as P
import qualified Present.Text as P
import Present.Types
import Control.Applicative ((<|>))
import Control.Monad
import Data.Data
import Data.Data.Exists
import Data.Data.Indexed
import Data.Default
import Data.Semigroup
import Data.Text (pack)
data Normalizer = forall a b. (Data a,Data b) => Norm (a -> b)
present :: Data a => ID -> a -> Maybe Presentation
present iq = hunt iq def iq
hunt :: Data d => ID -> ID -> ID -> d -> Maybe Presentation
hunt iq c q d =
normalize d normalizers <|> dissect iq c q d
where
normalize a = foldr mplus mzero . map (tryNormalize a)
tryNormalize x (Norm convert) = cast x >>= retry . convert
retry :: Data r => r -> Maybe Presentation
retry = hunt iq c q
normalizers :: [Normalizer]
normalizers =
[Norm P.normalizeText
,Norm P.normalizeStrictText
,Norm P.normalizeByteString
,Norm P.normalizeStrictByteString
,Norm P.normalizeString]
dissect :: Data d => ID -> ID -> ID -> d -> Maybe Presentation
dissect iq c q d =
case ID.split q of
(i,Nothing) ->
if ID.singleton i == c
then presentation iq d
else Nothing
(i,Just q') ->
if ID.singleton i == c
then case gindex i' d of
Nothing -> Nothing
Just (D d') -> hunt iq (ID.singleton i') q' d'
else Nothing
where (i',_) = ID.split q'
presentation :: Data a => ID -> a -> Maybe Presentation
presentation iq d =
case dataTypeRep dtype of
AlgRep{} -> Just (presentAlgebraic iq d)
IntRep -> Just (Integer ty text)
FloatRep -> Just (Floating ty text)
CharRep -> Just (Char ty text)
NoRep -> Nothing
where text = pack (show (toConstr d))
ty = pack (show (typeOf d))
dtype = dataTypeOf d
presentAlgebraic :: Data a => ID -> a -> Presentation
presentAlgebraic iq d =
case cast d of
Just (_ :: P.String) -> String ty ids
Nothing ->
case cast d of
Just (_ :: P.Text) -> String ty ids
Nothing ->
case cast d of
Just (_ :: P.ByteString) -> String ty ids
Nothing ->
case show (toConstr d) of
"[]" -> List ty []
"()" -> Tuple ty []
"(:)" -> List ty ids
"(,)" -> Tuple ty ids
_ ->
case constrFields (toConstr d) of
[] -> Alg ty text ids
fields -> Record ty text (zip (map pack fields) ids)
where ty = pack (show (typeOf d))
text = pack (show (toConstr d))
ids = gappend makeId d
where makeId d_i i =
return (pack (show (typeOf d_i))
,iq <> ID.singleton i)
asData :: Data a => a -> a
asData = id