content: {- |
  Module      :  ./atermlib/src/ATerm/Conversion.hs
  Description :  the class ShATermConvertible and basic instances
  Copyright   :  (c) Klaus Luettich, C. Maeder, Uni Bremen 2002-2006
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  non-portable(imports ATerm.AbstractSyntax)
  
  the class 'ShATermConvertible' depending on the class 'Typeable' for
  converting datatypes to and from 'ShATerm's in 'ATermTable's, plus a
  couple of basic instances and utilities
  -}
  
  module ATerm.Conversion where
  
  import ATerm.AbstractSyntax
  import qualified Data.Map as Map
  import qualified Data.IntMap as IntMap
  import qualified Data.Set as Set
  import Data.Typeable
  import Data.List (mapAccumL)
  import Data.Ratio
  import Data.Word
  import Control.Monad
  
  class Typeable t => ShATermConvertible t where
      -- functions for conversion to an ATermTable
      toShATermAux :: ATermTable -> t -> IO (ATermTable, Int)
      toShATermList' :: ATermTable -> [t] -> IO (ATermTable, Int)
      fromShATermAux :: Int -> ATermTable -> (ATermTable, t)
      fromShATermList' :: Int -> ATermTable -> (ATermTable, [t])
  
      -- default functions ignore the Annotation part
      toShATermList' att ts = do
             (att2, inds) <- foldM (\ (att0, l) t -> do
                      (att1, i) <- toShATerm' att0 t
                      return (att1, i : l)) (att, []) ts
             return $ addATerm (ShAList (reverse inds) []) att2
  
      fromShATermList' ix att0 =
          case getShATerm ix att0 of
              ShAList ats _ ->
                  mapAccumL (flip fromShATerm') att0 ats
              u -> fromShATermError "[]" u
  
  toShATerm' :: ShATermConvertible t => ATermTable -> t -> IO (ATermTable, Int)
  toShATerm' att t = do
         k <- mkKey t
         m <- getKey k att
         case m of
           Nothing -> do
             (att1, i) <- toShATermAux att t
             setKey k i att1
           Just i -> return (att, i)
  
  fromShATerm' :: ShATermConvertible t => Int -> ATermTable -> (ATermTable, t)
  fromShATerm' i att = case getATerm' i att of
          Just d -> (att, d)
          _ -> case fromShATermAux i att of
                 (attN, t) -> (setATerm' i t attN, t)
  
  fromShATermError :: String -> ShATerm -> a
  fromShATermError t u =
    error $ "Cannot convert ShATerm to " ++ t ++ ": !" ++ show u
  
  -- some instances -----------------------------------------------
  instance ShATermConvertible Bool where
      toShATermAux att b = return
        $ addATerm (ShAAppl (if b then "T" else "F") [] []) att
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "T" [] _ -> (att0, True)
              ShAAppl "F" [] _ -> (att0, False)
              u -> fromShATermError "Prelude.Bool" u
  
  instance ShATermConvertible Integer where
      toShATermAux att x = return $ addATerm (ShAInt x []) att
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAInt x _ -> (att0, x)
              u -> fromShATermError "Prelude.Integer" u
  
  instance ShATermConvertible Int where
      toShATermAux att = toShATermAux att . toInteger
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAInt x _ -> (att0, integer2Int x)
              u -> fromShATermError "Prelude.Int" u
  
  instance ShATermConvertible Word8 where
      toShATermAux att = toShATermAux att . toInteger
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAInt x _ | x <= toInteger (maxBound :: Word8)
                           && x >= toInteger (minBound :: Word8)
                -> (att0, fromIntegral x)
              u -> fromShATermError "Data.Word8" u
  
  instance (ShATermConvertible a, Integral a)
      => ShATermConvertible (Ratio a) where
      toShATermAux att0 i = do
         (att1, i1') <- toShATerm' att0 $ numerator i
         (att2, i2') <- toShATerm' att1 $ denominator i
         return $ addATerm (ShAAppl "Ratio" [i1', i2'] []) att2
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "Ratio" [a, b] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      case fromShATerm' b att1 of { (att2, b') ->
                      (att2, a' % b') }}
              u -> fromShATermError "Prelude.Integral" u
  
  instance ShATermConvertible Float where
      toShATermAux att = toShATermAux att . toRational
      fromShATermAux ix att0 = case fromShATermAux ix att0 of
         (att, r) -> (att, fromRational r)
  
  instance ShATermConvertible Char where
      toShATermAux att c = return $ addATerm (ShAAppl (show [c]) [] []) att
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl s [] _ -> (att0, str2Char s)
              u -> fromShATermError "Prelude.Char" u
      toShATermList' att s = return $ addATerm (ShAAppl (show s) [] []) att
      fromShATermList' ix att0 = case getShATerm ix att0 of
              ShAAppl s [] _ -> (att0, read s)
              u -> fromShATermError "Prelude.String" u
  
  instance ShATermConvertible () where
      toShATermAux att _ = return $ addATerm (ShAAppl "U" [] []) att
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "U" [] _ -> (att0, ())
              u -> fromShATermError "()" u
  
  instance (ShATermConvertible a) => ShATermConvertible (Maybe a) where
      toShATermAux att mb = case mb of
          Nothing -> return $ addATerm (ShAAppl "N" [] []) att
          Just x -> do
            (att1, x') <- toShATerm' att x
            return $ addATerm (ShAAppl "J" [x'] []) att1
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "N" [] _ -> (att0, Nothing)
              ShAAppl "J" [a] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      (att1, Just a') }
              u -> fromShATermError "Prelude.Maybe" u
  
  instance (ShATermConvertible a, ShATermConvertible b)
      => ShATermConvertible (Either a b) where
      toShATermAux att0 (Left aa) = do
          (att1, aa') <- toShATerm' att0 aa
          return $ addATerm (ShAAppl "Left" [ aa' ] []) att1
      toShATermAux att0 (Right aa) = do
          (att1, aa') <- toShATerm' att0 aa
          return $ addATerm (ShAAppl "Right" [ aa' ] []) att1
      fromShATermAux ix att = case getShATerm ix att of
              ShAAppl "Left" [ aa ] _ ->
                      case fromShATerm' aa att of { (att2, aa') ->
                      (att2, Left aa') }
              ShAAppl "Right" [ aa ] _ ->
                      case fromShATerm' aa att of { (att2, aa') ->
                      (att2, Right aa') }
              u -> fromShATermError "Either" u
  
  instance ShATermConvertible a => ShATermConvertible [a] where
      toShATermAux = toShATermList'
      fromShATermAux = fromShATermList'
  
  instance (ShATermConvertible a, ShATermConvertible b)
      => ShATermConvertible (a, b) where
      toShATermAux att0 (x, y) = do
        (att1, x') <- toShATerm' att0 x
        (att2, y') <- toShATerm' att1 y
        return $ addATerm (ShAAppl "" [x', y'] []) att2
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "" [a, b] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      case fromShATerm' b att1 of { (att2, b') ->
                      (att2, (a', b'))}}
              u -> fromShATermError "(,)" u
  
  instance (ShATermConvertible a, ShATermConvertible b, ShATermConvertible c)
      => ShATermConvertible (a, b, c) where
      toShATermAux att0 (x, y, z) = do
        (att1, x') <- toShATerm' att0 x
        (att2, y') <- toShATerm' att1 y
        (att3, z') <- toShATerm' att2 z
        return $ addATerm (ShAAppl "" [x', y', z'] []) att3
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "" [a, b, c] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      case fromShATerm' b att1 of { (att2, b') ->
                      case fromShATerm' c att2 of { (att3, c') ->
                      (att3, (a', b', c'))}}}
              u -> fromShATermError "(,,)" u
  
  instance (ShATermConvertible a, ShATermConvertible b, ShATermConvertible c,
            ShATermConvertible d) => ShATermConvertible (a, b, c, d) where
    toShATermAux att0 (x, y, z, w) = do
        (att1, x') <- toShATerm' att0 x
        (att2, y') <- toShATerm' att1 y
        (att3, z') <- toShATerm' att2 z
        (att4, w') <- toShATerm' att3 w
        return $ addATerm (ShAAppl "" [x', y', z', w'] []) att4
    fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "" [a, b, c, d] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      case fromShATerm' b att1 of { (att2, b') ->
                      case fromShATerm' c att2 of { (att3, c') ->
                      case fromShATerm' d att3 of { (att4, d') ->
                      (att4, (a', b', c', d'))}}}}
              u -> fromShATermError "(,,,)" u
  
  instance (ShATermConvertible a, ShATermConvertible b)
      => ShATermConvertible (Map.Map a b) where
      toShATermAux att fm = do
        (att1, i) <- toShATerm' att $ Map.toList fm
        return $ addATerm (ShAAppl "Map" [i] []) att1
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "Map" [a] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      (att1, Map.fromDistinctAscList a') }
              u -> fromShATermError "Map.Map" u
  
  instance ShATermConvertible a => ShATermConvertible (IntMap.IntMap a) where
    toShATermAux att fm = do
        (att1, i) <- toShATerm' att $ IntMap.toList fm
        return $ addATerm (ShAAppl "IntMap" [i] []) att1
    fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "IntMap" [a] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      (att1, IntMap.fromDistinctAscList a') }
              u -> fromShATermError "IntMap.IntMap" u
  
  instance ShATermConvertible a => ShATermConvertible (Set.Set a) where
      toShATermAux att set = do
        (att1, i) <- toShATerm' att $ Set.toList set
        return $ addATerm (ShAAppl "Set" [i] []) att1
      fromShATermAux ix att0 = case getShATerm ix att0 of
              ShAAppl "Set" [a] _ ->
                      case fromShATerm' a att0 of { (att1, a') ->
                      (att1, Set.fromDistinctAscList a') }
              u -> fromShATermError "Set.Set" u
  