{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}
module Util.AtomString(
AtomString,
firstAtomString,
StringClass(..),
fromStringWEHacked,
fromStringError,
Str(..),
mkFromStringWE,
) where
import Control.Concurrent
import qualified Data.Map as Map
import System.IO.Unsafe
import qualified Data.ByteString.Char8 as BS
import Control.Exception
import Text.ParserCombinators.Parsec
import Util.QuickReadShow
import Util.Dynamics
import Util.DeepSeq
import Util.Computation
import Util.BinaryAll
data AtomSource = AtomSource (MVar (Map.Map BS.ByteString AtomString))
emptyAtomSource :: IO AtomSource
emptyAtomSource :: IO AtomSource
emptyAtomSource =
do
MVar (Map ByteString AtomString)
mVar <- Map ByteString AtomString -> IO (MVar (Map ByteString AtomString))
forall a. a -> IO (MVar a)
newMVar Map ByteString AtomString
forall k a. Map k a
Map.empty
AtomSource -> IO AtomSource
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Map ByteString AtomString) -> AtomSource
AtomSource MVar (Map ByteString AtomString)
mVar)
theAtomSource :: AtomSource
theAtomSource :: AtomSource
theAtomSource = IO AtomSource -> AtomSource
forall a. IO a -> a
unsafePerformIO IO AtomSource
emptyAtomSource
{-# NOINLINE theAtomSource #-}
newtype AtomString = AtomString BS.ByteString deriving (Eq AtomString
Eq AtomString
-> (AtomString -> AtomString -> Ordering)
-> (AtomString -> AtomString -> Bool)
-> (AtomString -> AtomString -> Bool)
-> (AtomString -> AtomString -> Bool)
-> (AtomString -> AtomString -> Bool)
-> (AtomString -> AtomString -> AtomString)
-> (AtomString -> AtomString -> AtomString)
-> Ord AtomString
AtomString -> AtomString -> Bool
AtomString -> AtomString -> Ordering
AtomString -> AtomString -> AtomString
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AtomString -> AtomString -> AtomString
$cmin :: AtomString -> AtomString -> AtomString
max :: AtomString -> AtomString -> AtomString
$cmax :: AtomString -> AtomString -> AtomString
>= :: AtomString -> AtomString -> Bool
$c>= :: AtomString -> AtomString -> Bool
> :: AtomString -> AtomString -> Bool
$c> :: AtomString -> AtomString -> Bool
<= :: AtomString -> AtomString -> Bool
$c<= :: AtomString -> AtomString -> Bool
< :: AtomString -> AtomString -> Bool
$c< :: AtomString -> AtomString -> Bool
compare :: AtomString -> AtomString -> Ordering
$ccompare :: AtomString -> AtomString -> Ordering
$cp1Ord :: Eq AtomString
Ord,AtomString -> AtomString -> Bool
(AtomString -> AtomString -> Bool)
-> (AtomString -> AtomString -> Bool) -> Eq AtomString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AtomString -> AtomString -> Bool
$c/= :: AtomString -> AtomString -> Bool
== :: AtomString -> AtomString -> Bool
$c== :: AtomString -> AtomString -> Bool
Eq,Typeable)
firstAtomString :: AtomString
firstAtomString :: AtomString
firstAtomString = ByteString -> AtomString
AtomString (String -> ByteString
BS.pack String
"")
class StringClass stringClass where
toString :: stringClass -> String
fromString :: String -> stringClass
fromString String
s = WithError stringClass -> stringClass
forall a. WithError a -> a
coerceWithError (String -> WithError stringClass
forall stringClass.
StringClass stringClass =>
String -> WithError stringClass
fromStringWE String
s)
fromStringWE :: String -> WithError stringClass
fromStringWE String
s = stringClass -> WithError stringClass
forall a. a -> WithError a
hasValue (String -> stringClass
forall stringClass.
StringClass stringClass =>
String -> stringClass
fromString String
s)
instance StringClass AtomString where
fromString :: String -> AtomString
fromString String
string = IO AtomString -> AtomString
forall a. IO a -> a
unsafePerformIO (String -> IO AtomString
mkAtom String
string)
toString :: AtomString -> String
toString AtomString
atom = IO String -> String
forall a. IO a -> a
unsafePerformIO (AtomString -> IO String
readAtom AtomString
atom)
instance StringClass stringClass => QuickRead stringClass where
quickRead :: WrapRead stringClass
quickRead = (String -> stringClass) -> WrapRead stringClass
forall toRead read.
Read read =>
(read -> toRead) -> WrapRead toRead
WrapRead String -> stringClass
forall stringClass.
StringClass stringClass =>
String -> stringClass
fromString
instance StringClass stringClass => QuickShow stringClass where
quickShow :: WrapShow stringClass
quickShow = (stringClass -> String) -> WrapShow stringClass
forall toShow show.
Show show =>
(toShow -> show) -> WrapShow toShow
WrapShow stringClass -> String
forall stringClass.
StringClass stringClass =>
stringClass -> String
toString
fromStringWEHacked :: (StringClass stringClass,DeepSeq stringClass)
=> String -> IO (WithError stringClass)
fromStringWEHacked :: String -> IO (WithError stringClass)
fromStringWEHacked String
str =
do
Either String stringClass
either <- (Dyn -> Maybe String)
-> IO stringClass -> IO (Either String stringClass)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust
(\ Dyn
dyn ->
case Dyn -> Maybe FromStringExcep
forall a. Typeable a => Dyn -> Maybe a
fromDynamic Dyn
dyn of
Maybe FromStringExcep
Nothing -> Maybe String
forall a. Maybe a
Nothing
Just (FromStringExcep String
mess) -> String -> Maybe String
forall a. a -> Maybe a
Just String
mess
)
(do
let
value :: stringClass
value = String -> stringClass
forall stringClass.
StringClass stringClass =>
String -> stringClass
fromString String
str
stringClass -> IO () -> IO ()
forall a b. DeepSeq a => a -> b -> b
deepSeq stringClass
value IO ()
forall (m :: * -> *). Monad m => m ()
done
stringClass -> IO stringClass
forall (m :: * -> *) a. Monad m => a -> m a
return stringClass
value
)
WithError stringClass -> IO (WithError stringClass)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String stringClass -> WithError stringClass
forall a. Either String a -> WithError a
toWithError Either String stringClass
either)
fromStringError :: String -> a
fromStringError :: String -> a
fromStringError String
mess = Dyn -> a
forall a e. Exception e => e -> a
throw (Dyn -> a) -> Dyn -> a
forall a b. (a -> b) -> a -> b
$ FromStringExcep -> Dyn
forall a. Typeable a => a -> Dyn
toDyn (String -> FromStringExcep
FromStringExcep String
mess)
newtype FromStringExcep = FromStringExcep String deriving (Typeable)
mkAtom :: String -> IO AtomString
mkAtom :: String -> IO AtomString
mkAtom String
str =
do
let
packed :: ByteString
packed = String -> ByteString
BS.pack String
str
AtomSource MVar (Map ByteString AtomString)
mVar = AtomSource
theAtomSource
Map ByteString AtomString
map <- MVar (Map ByteString AtomString) -> IO (Map ByteString AtomString)
forall a. MVar a -> IO a
takeMVar MVar (Map ByteString AtomString)
mVar
let
(AtomString
result,Map ByteString AtomString
newMap) = case ByteString -> Map ByteString AtomString -> Maybe AtomString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
packed Map ByteString AtomString
map of
Maybe AtomString
Nothing ->
(ByteString -> AtomString
AtomString ByteString
packed,ByteString
-> AtomString
-> Map ByteString AtomString
-> Map ByteString AtomString
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
packed (ByteString -> AtomString
AtomString ByteString
packed) Map ByteString AtomString
map)
Just AtomString
newPacked -> (AtomString
newPacked,Map ByteString AtomString
map)
MVar (Map ByteString AtomString)
-> Map ByteString AtomString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Map ByteString AtomString)
mVar Map ByteString AtomString
newMap
AtomString -> IO AtomString
forall (m :: * -> *) a. Monad m => a -> m a
return AtomString
result
readAtom :: AtomString -> IO String
readAtom :: AtomString -> IO String
readAtom (AtomString ByteString
packedString) =
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return(ByteString -> String
BS.unpack ByteString
packedString)
mkFromStringWE :: Parser stringClass -> String
-> (String -> WithError stringClass)
mkFromStringWE :: Parser stringClass -> String -> String -> WithError stringClass
mkFromStringWE (Parser stringClass
parser0 :: Parser stringClass) String
typeName String
str =
let
parser1 :: Parser stringClass
parser1 =
do
stringClass
result <- Parser stringClass
parser0
ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
stringClass -> Parser stringClass
forall (m :: * -> *) a. Monad m => a -> m a
return stringClass
result
in
case Parser stringClass
-> String -> String -> Either ParseError stringClass
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser stringClass
parser1 String
"" String
str of
Right stringClass
stringClass -> stringClass -> WithError stringClass
forall a. a -> WithError a
hasValue stringClass
stringClass
Left ParseError
_ -> String -> WithError stringClass
forall a. String -> WithError a
hasError (String -> String
forall a. Show a => a -> String
show String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a valid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName)
newtype Str a = Str a
instance (Monad m,StringClass a) => HasBinary (Str a) m where
writeBin :: WriteBinary m -> Str a -> m ()
writeBin = (Str a -> String) -> WriteBinary m -> Str a -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (Str a
a) -> a -> String
forall stringClass.
StringClass stringClass =>
stringClass -> String
toString a
a)
readBin :: ReadBinary m -> m (Str a)
readBin = (String -> Str a) -> ReadBinary m -> m (Str a)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ String
str -> a -> Str a
forall a. a -> Str a
Str (String -> a
forall stringClass.
StringClass stringClass =>
String -> stringClass
fromString String
str))