content: {-# LANGUAGE MagicHash #-}
  {- |
  Module      :  ./atermlib/src/ATerm/AbstractSyntax.hs
  Description :  the abstract syntax of shared ATerms and their lookup table
  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 System.Mem.StableName and GHC.Prim)
  
  the data types 'ShATerm' and 'ATermTable' plus some utilities
  -}
  
  module ATerm.AbstractSyntax
      (ShATerm (..),
       ATermTable,
       emptyATermTable,
       addATerm,
       getATerm, toReadonlyATT,
       getTopIndex,
       getATerm', setATerm', getShATerm,
       Key, getKey, setKey, mkKey,
       getATermByIndex1, str2Char, integer2Int
      ) where
  
  import qualified Data.Map as Map
  import qualified Data.Map as IntMap
  import Data.Dynamic
  import Data.Typeable
  import Data.Array
  import System.Mem.StableName
  import Unsafe.Coerce
  import qualified Data.List as List
  import Data.Maybe
  
  data ShATerm =
      ShAAppl String [Int] [Int]
    | ShAList [Int] [Int]
    | ShAInt Integer [Int]
      deriving (Show, Eq, Ord)
  
  data IntMap =
      Updateable !(IntMap.Map Int ShATerm)
    | Readonly !(Array Int ShATerm)
  
  empty :: IntMap
  empty = Updateable IntMap.empty
  
  insert :: Int -> ShATerm -> IntMap -> IntMap
  insert i s t = case t of
      Updateable m -> Updateable $ IntMap.insert i s m
      _ -> error "ATerm.insert"
  
  find :: Int -> IntMap -> ShATerm
  find i t = case t of
      Updateable m -> IntMap.findWithDefault (ShAInt (-1) []) i m
      Readonly a -> a ! i
  
  data EqKey = EqKey (StableName ()) TypeRep deriving Eq
  
  data Key = Key Int EqKey
  
  mkKey :: Typeable a => a -> IO Key
  mkKey t = do
      s <- makeStableName t
      return $ Key (hashStableName s) $ EqKey (unsafeCoerce# s) $ typeOf t
  
  data ATermTable = ATT
      (IntMap.Map Int [(EqKey, Int)])
      !(Map.Map ShATerm Int) !IntMap Int
      !(IntMap.Map Int [Dynamic])
  
  toReadonlyATT :: ATermTable -> ATermTable
  toReadonlyATT (ATT h s t i dM) = ATT h s
      (case t of
       Updateable m -> Readonly $ listArray (0, i) $ IntMap.elems m
       _ -> t ) i dM
  
  emptyATermTable :: ATermTable
  emptyATermTable = ATT IntMap.empty Map.empty empty (-1) IntMap.empty
  
  addATermNoFullSharing :: ShATerm -> ATermTable -> (ATermTable, Int)
  addATermNoFullSharing t (ATT h a_iDFM i_aDFM i1 dM) = let j = i1 + 1 in
      (ATT h (Map.insert t j a_iDFM) (insert j t i_aDFM) j dM, j)
  
  addATerm :: ShATerm -> ATermTable -> (ATermTable, Int)
  addATerm t at@(ATT _ a_iDFM _ _ _) =
    case Map.lookup t a_iDFM of
      Nothing -> addATermNoFullSharing t at
      Just i -> (at, i)
  
  setKey :: Key -> Int -> ATermTable -> IO (ATermTable, Int)
  setKey (Key h e) i (ATT t s l m d) =
      return (ATT (IntMap.insertWith (++) h [(e, i)] t) s l m d, i)
  
  getKey :: Key -> ATermTable -> IO (Maybe Int)
  getKey (Key h k) (ATT t _ _ _ _) =
      return $ List.lookup k $ IntMap.findWithDefault [] h t
  
  getATerm :: ATermTable -> ShATerm
  getATerm (ATT _ _ i_aFM i _) = find i i_aFM
  
  getShATerm :: Int -> ATermTable -> ShATerm
  getShATerm i (ATT _ _ i_aFM _ _) = find i i_aFM
  
  getTopIndex :: ATermTable -> Int
  getTopIndex (ATT _ _ _ i _) = i
  
  getATermByIndex1 :: Int -> ATermTable -> ATermTable
  getATermByIndex1 i (ATT h a_iDFM i_aDFM _ dM) = ATT h a_iDFM i_aDFM i dM
  
  getATerm' :: Typeable t => Int -> ATermTable -> Maybe t
  getATerm' i (ATT _ _ _ _ dM) =
      listToMaybe $ mapMaybe fromDynamic $ IntMap.findWithDefault [] i dM
  
  setATerm' :: Typeable t => Int -> t -> ATermTable -> ATermTable
  setATerm' i t (ATT h a_iDFM i_aDFM m dM) =
      ATT h a_iDFM i_aDFM m $ IntMap.insertWith (++) i [toDyn t] dM
  
  -- | conversion of a string in double quotes to a character
  str2Char :: String -> Char
  str2Char str = case str of
      '\"' : sr@(_ : _) -> conv' (init sr) where
        conv' r = case r of
          [x] -> x
          ['\\', x] -> case x of
            'n' -> '\n'
            't' -> '\t'
            'r' -> '\r'
            '\"' -> '\"'
            _ -> error "ATerm.AbstractSyntax: unexpected escape sequence"
          _ -> error "ATerm.AbstractSyntax: String not convertible to Char"
      _ -> error "ATerm.AbstractSyntax: String doesn't begin with '\"'"
  
  -- | conversion of an unlimited integer to a machine int
  integer2Int :: Integer -> Int
  integer2Int x = if toInteger ((fromInteger :: Integer -> Int) x) == x
      then fromInteger x else
      error $ "ATerm.AbstractSyntax: Integer to big for Int: " ++ show x
  