module GBMonad (
TransFun, transTabToTransFun,
HsObject(..), GB, HsPtrRep, initialGBState, setContext, getLibrary,
getPrefix, getLock, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,
queryObj, queryClass, queryPointer, mergeMaps, dumpMaps
) where
import Data.Char (toUpper, toLower, isSpace)
import Data.List (find)
import Data.Maybe (fromMaybe)
import Position (Position, Pos(posOf), nopos, builtinPos)
import Errors (interr)
import Idents (Ident, identToLexeme, onlyPosIdent)
import Map (Map)
import qualified Map as Map (empty, insert, lookup, fromList, toList, union)
import C (CT, readCT, transCT, raiseErrorCTExc)
import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
CHSAccess(..), CHSAPath(..), CHSPtrType(..))
type TransFun = Ident -> String
underscoreToCase :: TransFun
underscoreToCase :: TransFun
underscoreToCase Ident
ide = let lexeme :: String
lexeme = TransFun
identToLexeme Ident
ide
ps :: [String]
ps = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
parts forall a b. (a -> b) -> a -> b
$ String
lexeme
in
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> String
adjustCase forall a b. (a -> b) -> a -> b
$ [String]
ps
where
parts :: String -> [String]
parts String
s = let (String
l, String
s') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'_') String
s
in
String
l forall a. a -> [a] -> [a]
: case String
s' of
[] -> []
(Char
_:String
s'') -> String -> [String]
parts String
s''
adjustCase :: String -> String
adjustCase (Char
c:String
cs) = Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cs
transTabToTransFun :: String -> CHSTrans -> TransFun
transTabToTransFun :: String -> CHSTrans -> TransFun
transTabToTransFun String
prefix (CHSTrans Bool
_2Case [(Ident, Ident)]
table) =
\Ident
ide -> let
lexeme :: String
lexeme = TransFun
identToLexeme Ident
ide
dft :: String
dft = if Bool
_2Case
then TransFun
underscoreToCase Ident
ide
else String
lexeme
in
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
ide [(Ident, Ident)]
table of
Just Ident
ide' -> TransFun
identToLexeme Ident
ide'
Maybe Ident
Nothing ->
case String -> String -> Maybe String
eat String
prefix String
lexeme of
Maybe String
Nothing -> String
dft
Just String
eatenLexeme ->
let
eatenIde :: Ident
eatenIde = Position -> String -> Ident
onlyPosIdent (forall a. Pos a => a -> Position
posOf Ident
ide) String
eatenLexeme
eatenDft :: String
eatenDft = if Bool
_2Case
then TransFun
underscoreToCase Ident
eatenIde
else String
eatenLexeme
in
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
eatenIde [(Ident, Ident)]
table of
Maybe Ident
Nothing -> String
eatenDft
Just Ident
ide' -> TransFun
identToLexeme Ident
ide'
where
eat :: String -> String -> Maybe String
eat [] (Char
'_':String
cs) = String -> String -> Maybe String
eat [] String
cs
eat [] String
cs = forall a. a -> Maybe a
Just String
cs
eat (Char
p:String
prefix) (Char
c:String
cs) | Char -> Char
toUpper Char
p forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
c = String -> String -> Maybe String
eat String
prefix String
cs
| Bool
otherwise = forall a. Maybe a
Nothing
eat String
_ String
_ = forall a. Maybe a
Nothing
type PointerMap = Map (Bool, Ident) HsPtrRep
type HsPtrRep = (Bool, CHSPtrType, Maybe String, String)
data HsObject = Pointer {
HsObject -> CHSPtrType
ptrTypeHO :: CHSPtrType,
HsObject -> Bool
isNewtypeHO :: Bool
}
| Class {
HsObject -> Maybe Ident
superclassHO :: (Maybe Ident),
HsObject -> Ident
ptrHO :: Ident
}
deriving (Int -> HsObject -> String -> String
[HsObject] -> String -> String
HsObject -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HsObject] -> String -> String
$cshowList :: [HsObject] -> String -> String
show :: HsObject -> String
$cshow :: HsObject -> String
showsPrec :: Int -> HsObject -> String -> String
$cshowsPrec :: Int -> HsObject -> String -> String
Show, ReadPrec [HsObject]
ReadPrec HsObject
Int -> ReadS HsObject
ReadS [HsObject]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HsObject]
$creadListPrec :: ReadPrec [HsObject]
readPrec :: ReadPrec HsObject
$creadPrec :: ReadPrec HsObject
readList :: ReadS [HsObject]
$creadList :: ReadS [HsObject]
readsPrec :: Int -> ReadS HsObject
$creadsPrec :: Int -> ReadS HsObject
Read)
type HsObjectMap = Map Ident HsObject
instance Read Ident where
readsPrec :: Int -> ReadS Ident
readsPrec Int
_ (Char
'`':String
lexeme) = let (String
ideChars, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'\'') String
lexeme
in
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ideChars
then []
else [(Position -> String -> Ident
onlyPosIdent Position
nopos String
ideChars, forall a. [a] -> [a]
tail String
rest)]
readsPrec Int
p (Char
c:String
cs)
| Char -> Bool
isSpace Char
c = forall a. Read a => Int -> ReadS a
readsPrec Int
p String
cs
readsPrec Int
_ String
_ = []
data GBState = GBState {
GBState -> String
lib :: String,
GBState -> String
prefix :: String,
GBState -> Maybe String
mLock :: Maybe String,
GBState -> [(CHSHook, CHSFrag)]
frags :: [(CHSHook, CHSFrag)],
GBState -> PointerMap
ptrmap :: PointerMap,
GBState -> HsObjectMap
objmap :: HsObjectMap
}
type GB a = CT GBState a
initialGBState :: Maybe String -> GBState
initialGBState :: Maybe String -> GBState
initialGBState Maybe String
mLock = GBState {
lib :: String
lib = String
"",
prefix :: String
prefix = String
"",
mLock :: Maybe String
mLock = Maybe String
mLock,
frags :: [(CHSHook, CHSFrag)]
frags = [],
ptrmap :: PointerMap
ptrmap = forall k a. Map k a
Map.empty,
objmap :: HsObjectMap
objmap = forall k a. Map k a
Map.empty
}
setContext :: (Maybe String) -> (Maybe String) -> (Maybe String) ->
GB ()
setContext :: Maybe String -> Maybe String -> Maybe String -> GB ()
setContext Maybe String
lib Maybe String
prefix Maybe String
newMLock =
forall s a. (s -> (s, a)) -> CT s a
transCT forall a b. (a -> b) -> a -> b
$ \GBState
state -> (GBState
state {lib :: String
lib = forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
lib,
prefix :: String
prefix = forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
prefix,
mLock :: Maybe String
mLock = case Maybe String
newMLock of
Maybe String
Nothing -> GBState -> Maybe String
mLock GBState
state
Just String
_ -> Maybe String
newMLock },
())
getLibrary :: GB String
getLibrary :: GB String
getLibrary = forall s a. (s -> a) -> CT s a
readCT GBState -> String
lib
getPrefix :: GB String
getPrefix :: GB String
getPrefix = forall s a. (s -> a) -> CT s a
readCT GBState -> String
prefix
getLock :: GB (Maybe String)
getLock :: GB (Maybe String)
getLock = forall s a. (s -> a) -> CT s a
readCT GBState -> Maybe String
mLock
delayCode :: CHSHook -> String -> GB ()
delayCode :: CHSHook -> String -> GB ()
delayCode CHSHook
hook String
str =
do
[(CHSHook, CHSFrag)]
frags <- forall s a. (s -> a) -> CT s a
readCT GBState -> [(CHSHook, CHSFrag)]
frags
[(CHSHook, CHSFrag)]
frags' <- CHSHook
-> [(CHSHook, CHSFrag)]
-> PreCST SwitchBoard (CState GBState) [(CHSHook, CHSFrag)]
delay CHSHook
hook [(CHSHook, CHSFrag)]
frags
forall s a. (s -> (s, a)) -> CT s a
transCT (\GBState
state -> (GBState
state {frags :: [(CHSHook, CHSFrag)]
frags = [(CHSHook, CHSFrag)]
frags'}, ()))
where
newEntry :: (CHSHook, CHSFrag)
newEntry = (CHSHook
hook, (String -> Position -> CHSFrag
CHSVerb (String
"\n" forall a. [a] -> [a] -> [a]
++ String
str) (forall a. Pos a => a -> Position
posOf CHSHook
hook)))
delay :: CHSHook
-> [(CHSHook, CHSFrag)]
-> PreCST SwitchBoard (CState GBState) [(CHSHook, CHSFrag)]
delay hook :: CHSHook
hook@(CHSCall Bool
isFun Bool
isUns Bool
_ Ident
ide Maybe Ident
oalias Position
_) [(CHSHook, CHSFrag)]
frags =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(CHSHook
hook', CHSFrag
_) -> CHSHook
hook' forall a. Eq a => a -> a -> Bool
== CHSHook
hook) [(CHSHook, CHSFrag)]
frags of
Just (CHSCall Bool
isFun' Bool
isUns' Bool
_ Ident
ide' Maybe Ident
_ Position
_, CHSFrag
_)
| Bool
isFun forall a. Eq a => a -> a -> Bool
== Bool
isFun'
Bool -> Bool -> Bool
&& Bool
isUns forall a. Eq a => a -> a -> Bool
== Bool
isUns'
Bool -> Bool -> Bool
&& Ident
ide forall a. Eq a => a -> a -> Bool
== Ident
ide' -> forall (m :: * -> *) a. Monad m => a -> m a
return [(CHSHook, CHSFrag)]
frags
| Bool
otherwise -> forall {a}. Position -> Position -> GB a
err (forall a. Pos a => a -> Position
posOf Ident
ide) (forall a. Pos a => a -> Position
posOf Ident
ide')
Maybe (CHSHook, CHSFrag)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(CHSHook, CHSFrag)]
frags forall a. [a] -> [a] -> [a]
++ [(CHSHook, CHSFrag)
newEntry]
delay CHSHook
_ [(CHSHook, CHSFrag)]
_ =
forall a. String -> a
interr String
"GBMonad.delayCode: Illegal delay!"
err :: Position -> Position -> GB a
err = forall {a}. Position -> Position -> GB a
incompatibleCallHooksErr
getDelayedCode :: GB [CHSFrag]
getDelayedCode :: GB [CHSFrag]
getDelayedCode = forall s a. (s -> a) -> CT s a
readCT (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. GBState -> [(CHSHook, CHSFrag)]
frags)
ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB ()
(Bool
isStar, Ident
cName) ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB ()
`ptrMapsTo` HsPtrRep
hsRepr =
forall s a. (s -> (s, a)) -> CT s a
transCT (\GBState
state -> (GBState
state {
ptrmap :: PointerMap
ptrmap = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Bool
isStar, Ident
cName) HsPtrRep
hsRepr (GBState -> PointerMap
ptrmap GBState
state)
}, ()))
queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep)
queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep)
queryPtr (Bool, Ident)
pcName = do
PointerMap
fm <- forall s a. (s -> a) -> CT s a
readCT GBState -> PointerMap
ptrmap
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Bool, Ident)
pcName PointerMap
fm
objIs :: Ident -> HsObject -> GB ()
Ident
hsName objIs :: Ident -> HsObject -> GB ()
`objIs` HsObject
obj =
forall s a. (s -> (s, a)) -> CT s a
transCT (\GBState
state -> (GBState
state {
objmap :: HsObjectMap
objmap = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
hsName HsObject
obj (GBState -> HsObjectMap
objmap GBState
state)
}, ()))
queryObj :: Ident -> GB (Maybe HsObject)
queryObj :: Ident -> GB (Maybe HsObject)
queryObj Ident
hsName = do
HsObjectMap
fm <- forall s a. (s -> a) -> CT s a
readCT GBState -> HsObjectMap
objmap
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
hsName HsObjectMap
fm
queryClass :: Ident -> GB HsObject
queryClass :: Ident -> GB HsObject
queryClass Ident
hsName = do
let pos :: Position
pos = forall a. Pos a => a -> Position
posOf Ident
hsName
Maybe HsObject
oobj <- Ident -> GB (Maybe HsObject)
queryObj Ident
hsName
case Maybe HsObject
oobj of
Just obj :: HsObject
obj@(Class Maybe Ident
_ Ident
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return HsObject
obj
Just HsObject
_ -> forall a. Ident -> GB a
classExpectedErr Ident
hsName
Maybe HsObject
Nothing -> forall a. Ident -> GB a
hsObjExpectedErr Ident
hsName
queryPointer :: Ident -> GB HsObject
queryPointer :: Ident -> GB HsObject
queryPointer Ident
hsName = do
let pos :: Position
pos = forall a. Pos a => a -> Position
posOf Ident
hsName
Maybe HsObject
oobj <- Ident -> GB (Maybe HsObject)
queryObj Ident
hsName
case Maybe HsObject
oobj of
Just obj :: HsObject
obj@(Pointer CHSPtrType
_ Bool
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return HsObject
obj
Just HsObject
_ -> forall a. Ident -> GB a
pointerExpectedErr Ident
hsName
Maybe HsObject
Nothing -> forall a. Ident -> GB a
hsObjExpectedErr Ident
hsName
mergeMaps :: String -> GB ()
mergeMaps :: String -> GB ()
mergeMaps String
str =
forall s a. (s -> (s, a)) -> CT s a
transCT (\GBState
state -> (GBState
state {
ptrmap :: PointerMap
ptrmap = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (GBState -> PointerMap
ptrmap GBState
state) PointerMap
readPtrMap,
objmap :: HsObjectMap
objmap = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (GBState -> HsObjectMap
objmap GBState
state) HsObjectMap
readObjMap
}, ()))
where
([((Bool, String), HsPtrRep)]
ptrAssoc, [(String, HsObject)]
objAssoc) = forall a. Read a => String -> a
read String
str
readPtrMap :: PointerMap
readPtrMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((Bool
isStar, Position -> String -> Ident
onlyPosIdent Position
nopos String
ide), HsPtrRep
repr)
| ((Bool
isStar, String
ide), HsPtrRep
repr) <- [((Bool, String), HsPtrRep)]
ptrAssoc]
readObjMap :: HsObjectMap
readObjMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Position -> String -> Ident
onlyPosIdent Position
nopos String
ide, HsObject
obj)
| (String
ide, HsObject
obj) <- [(String, HsObject)]
objAssoc]
dumpMaps :: GB String
dumpMaps :: GB String
dumpMaps = do
PointerMap
ptrFM <- forall s a. (s -> a) -> CT s a
readCT GBState -> PointerMap
ptrmap
HsObjectMap
objFM <- forall s a. (s -> a) -> CT s a
readCT GBState -> HsObjectMap
objmap
let dumpable :: ([((Bool, String), HsPtrRep)], [(String, HsObject)])
dumpable = ([((Bool
isStar, TransFun
identToLexeme Ident
ide), HsPtrRep
repr)
| ((Bool
isStar, Ident
ide), HsPtrRep
repr) <- forall k a. Map k a -> [(k, a)]
Map.toList PointerMap
ptrFM],
[(TransFun
identToLexeme Ident
ide, HsObject
obj)
| (Ident
ide, HsObject
obj) <- forall k a. Map k a -> [(k, a)]
Map.toList HsObjectMap
objFM])
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ([((Bool, String), HsPtrRep)], [(String, HsObject)])
dumpable
incompatibleCallHooksErr :: Position -> Position -> GB a
incompatibleCallHooksErr :: forall {a}. Position -> Position -> GB a
incompatibleCallHooksErr Position
here Position
there =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
here
[String
"Incompatible call hooks!",
String
"There is a another call hook for the same C function at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
there,
String
"The flags and C function name of the two hooks should be identical,",
String
"but they are not."]
classExpectedErr :: Ident -> GB a
classExpectedErr :: forall a. Ident -> GB a
classExpectedErr Ident
ide =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Expected a class name!",
String
"Expected `" forall a. [a] -> [a] -> [a]
++ TransFun
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"' to refer to a class introduced",
String
"by a class hook."]
pointerExpectedErr :: Ident -> GB a
pointerExpectedErr :: forall a. Ident -> GB a
pointerExpectedErr Ident
ide =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Expected a pointer name!",
String
"Expected `" forall a. [a] -> [a] -> [a]
++ TransFun
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"' to be a type name introduced by",
String
"a pointer hook."]
hsObjExpectedErr :: Ident -> GB a
hsObjExpectedErr :: forall a. Ident -> GB a
hsObjExpectedErr Ident
ide =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Unknown name!",
String
"`" forall a. [a] -> [a] -> [a]
++ TransFun
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"' is unknown; it has *not* been defined by",
String
"a previous hook."]