0N/A{- |

1472N/AModule : $Header$

0N/ACopyright : (c) Klaus L�ttich, C. Maeder, Uni Bremen 2002-2006

0N/ALicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

0N/A

0N/AMaintainer : maeder@tzi.de

0N/AStability : provisional

0N/APortability : non-portable(imports System.Mem.StableName and GHC.Prim)

0N/A

0N/Adata types and utilities for shared ATerms and the ATermTable

0N/A-}

0N/A

0N/Amodule Common.ATerm.AbstractSyntax

0N/A (ShATerm(..),

0N/A ATermTable,

0N/A emptyATermTable,

0N/A addATerm,

0N/A getATerm, toReadonlyATT,

1472N/A getTopIndex,

1472N/A getATerm', setATerm', getShATerm,

1472N/A Key, newATermTable, getKey, setKey, mkKey,

0N/A getATermByIndex1, str2Char, integer2Int

0N/A ) where

0N/A

0N/Aimport qualified Common.Lib.Map as Map

0N/Aimport qualified Common.Lib.Map as IntMap

0N/Aimport Data.Dynamic

0N/Aimport Data.Array

0N/Aimport System.Mem.StableName

0N/Aimport GHC.Prim

import qualified Data.List as List

import Data.Maybe

data ShATerm = ShAAppl String [Int] [Int]

| ShAList [Int] [Int]

| ShAInt Integer [Int]

deriving (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

newATermTable :: IO ATermTable

newATermTable = return $ emptyATermTable

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 ('\"' : sr) = conv' (init sr) where

conv' [x] = x

conv' ['\\', x] = case x of

'n' -> '\n'

't' -> '\t'

'r' -> '\r'

'\"' -> '\"'

_ -> error "strToChar"

conv' _ = error "String not convertible to char"

str2Char _ = error "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 $ "Integer to big for Int: " ++ show x