src/ATerm/Conversion.hs

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