{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}

-- | AtomString atomises strings.  Right now this code
-- is not very efficient but it shouldn't be too hard
-- to improve.
--
-- This code includes no less that 3 uses of unsafePerformIO.  Oh well.
module Util.AtomString(
   AtomString,
      -- represents a string.  Instance of Ord, Eq, StringClass,
      -- Read and Show.  There is no guarantee that Ord on AtomString
      -- corresponds to Ord on the corresponding String.
   firstAtomString,
      -- :: AtomString
      -- However firstAtomString is guaranteed to be the first AtomString
      -- in the ordering.

   StringClass(..),
      -- encodes that a type encodes strings in some way.

   fromStringWEHacked,
   fromStringError,
      -- provide a primitive way for decoding String's to return an error.

   Str(..),
      -- WRAP


   mkFromStringWE,
      --  :: Parser stringClass -> String -> (String -> WithError stringClass)
      -- Make a fromStringWE function given a parser.
      -- The error message is of the form "/string/ is not a valid /typename/"
      -- where /typename/ is the first String argument to 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))
   -- where AtomStrings come from
   -- Here the key for an element is itself.


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 #-}
-- avoid GHC bug with Linux optimisation which can clone MVars.

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)
-- in fact Eq could be unsafePtrEq

firstAtomString :: AtomString
firstAtomString :: AtomString
firstAtomString = ByteString -> AtomString
AtomString (String -> ByteString
BS.pack String
"")

------------------------------------------------------------------------
-- StringClass
------------------------------------------------------------------------

class StringClass stringClass where
   toString :: stringClass -> String

   -- We leave it up to the instance whether fromString or fromStringWE or both
   -- are defined.  Most of the time we only use fromString, but there are
   -- just a few cases (such as EntityNames) where we need fromStringWE.
   --
   -- For cases where we don't have fromStringWE fromStringWEHacked provides
   -- an alternative solution, if you can bear it.
   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

------------------------------------------------------------------------
-- We provide a way for instances of StringClass to return errors from
-- fromString by using the usual dreadful hack with Exception.
------------------------------------------------------------------------

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 -- not a fromStringError.
                  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)

------------------------------------------------------------------------
-- StringClass instance
------------------------------------------------------------------------

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)
            -- now original copy of packed can be GC'd.
      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)

------------------------------------------------------------------------
-- How to make a fromStringWE given a Parsec parser.
------------------------------------------------------------------------

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)

------------------------------------------------------------------------
-- The Str class.  Wrapping an instance of StringClass in this gives
-- you an instance of HasBinary.
------------------------------------------------------------------------

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))