{-# 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 =
do
mVar <- newMVar Map.empty
return (AtomSource mVar)
theAtomSource :: AtomSource
theAtomSource = unsafePerformIO emptyAtomSource
{-# NOINLINE theAtomSource #-}
newtype AtomString = AtomString BS.ByteString deriving (Ord,Eq,Typeable)
firstAtomString :: AtomString
firstAtomString = AtomString (BS.pack "")
class StringClass stringClass where
toString :: stringClass -> String
fromString :: String -> stringClass
fromString s = coerceWithError (fromStringWE s)
fromStringWE :: String -> WithError stringClass
fromStringWE s = hasValue (fromString s)
instance StringClass AtomString where
fromString string = unsafePerformIO (mkAtom string)
toString atom = unsafePerformIO (readAtom atom)
instance StringClass stringClass => QuickRead stringClass where
quickRead = WrapRead fromString
instance StringClass stringClass => QuickShow stringClass where
quickShow = WrapShow toString
fromStringWEHacked :: (StringClass stringClass,DeepSeq stringClass)
=> String -> IO (WithError stringClass)
fromStringWEHacked str =
do
either <- tryJust
(\ dyn ->
case fromDynamic dyn of
Nothing -> Nothing
Just (FromStringExcep mess) -> Just mess
)
(do
let
value = fromString str
deepSeq value done
return value
)
return (toWithError either)
fromStringError :: String -> a
fromStringError mess = throw $ toDyn (FromStringExcep mess)
newtype FromStringExcep = FromStringExcep String deriving (Typeable)
mkAtom :: String -> IO AtomString
mkAtom str =
do
let
packed = BS.pack str
AtomSource mVar = theAtomSource
map <- takeMVar mVar
let
(result,newMap) = case Map.lookup packed map of
Nothing ->
(AtomString packed,Map.insert packed (AtomString packed) map)
Just newPacked -> (newPacked,map)
putMVar mVar newMap
return result
readAtom :: AtomString -> IO String
readAtom (AtomString packedString) =
return(BS.unpack packedString)
mkFromStringWE :: Parser stringClass -> String
-> (String -> WithError stringClass)
mkFromStringWE (parser0 :: Parser stringClass) typeName str =
let
parser1 =
do
result <- parser0
eof
return result
in
case parse parser1 "" str of
Right stringClass -> hasValue stringClass
Left _ -> hasError (show str ++ " is not a valid " ++ typeName)
newtype Str a = Str a
instance (Monad m,StringClass a) => HasBinary (Str a) m where
writeBin = mapWrite (\ (Str a) -> toString a)
readBin = mapRead (\ str -> Str (fromString str))