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 = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
parts (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
lexeme
in
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
adjustCase ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
ps
where
parts :: String -> [String]
parts String
s = let (String
l, String
s') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
s
in
String
l String -> [String] -> [String]
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 Char -> String -> String
forall a. a -> [a] -> [a]
: (Char -> Char) -> String -> String
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 Ident -> [(Ident, Ident)] -> Maybe Ident
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 (Ident -> Position
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 Ident -> [(Ident, Ident)] -> Maybe Ident
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 = String -> Maybe String
forall a. a -> Maybe a
Just String
cs
eat (Char
p:String
prefix) (Char
c:String
cs) | Char -> Char
toUpper Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
c = String -> String -> Maybe String
eat String
prefix String
cs
| Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
eat String
_ String
_ = Maybe 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
(Int -> HsObject -> String -> String)
-> (HsObject -> String)
-> ([HsObject] -> String -> String)
-> Show HsObject
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HsObject -> String -> String
showsPrec :: Int -> HsObject -> String -> String
$cshow :: HsObject -> String
show :: HsObject -> String
$cshowList :: [HsObject] -> String -> String
showList :: [HsObject] -> String -> String
Show, ReadPrec [HsObject]
ReadPrec HsObject
Int -> ReadS HsObject
ReadS [HsObject]
(Int -> ReadS HsObject)
-> ReadS [HsObject]
-> ReadPrec HsObject
-> ReadPrec [HsObject]
-> Read HsObject
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS HsObject
readsPrec :: Int -> ReadS HsObject
$creadList :: ReadS [HsObject]
readList :: ReadS [HsObject]
$creadPrec :: ReadPrec HsObject
readPrec :: ReadPrec HsObject
$creadListPrec :: ReadPrec [HsObject]
readListPrec :: ReadPrec [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) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'') String
lexeme
in
if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ideChars
then []
else [(Position -> String -> Ident
onlyPosIdent Position
nopos String
ideChars, String -> String
forall a. HasCallStack => [a] -> [a]
tail String
rest)]
readsPrec Int
p (Char
c:String
cs)
| Char -> Bool
isSpace Char
c = Int -> ReadS Ident
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 = PointerMap
forall k a. Map k a
Map.empty,
objmap :: HsObjectMap
objmap = HsObjectMap
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 =
(GBState -> (GBState, ())) -> GB ()
forall s a. (s -> (s, a)) -> CT s a
transCT ((GBState -> (GBState, ())) -> GB ())
-> (GBState -> (GBState, ())) -> GB ()
forall a b. (a -> b) -> a -> b
$ \GBState
state -> (GBState
state {lib = fromMaybe "" lib,
prefix = fromMaybe "" prefix,
mLock = case newMLock of
Maybe String
Nothing -> GBState -> Maybe String
mLock GBState
state
Just String
_ -> Maybe String
newMLock },
())
getLibrary :: GB String
getLibrary :: GB String
getLibrary = (GBState -> String) -> GB String
forall s a. (s -> a) -> CT s a
readCT GBState -> String
lib
getPrefix :: GB String
getPrefix :: GB String
getPrefix = (GBState -> String) -> GB String
forall s a. (s -> a) -> CT s a
readCT GBState -> String
prefix
getLock :: GB (Maybe String)
getLock :: GB (Maybe String)
getLock = (GBState -> Maybe String) -> GB (Maybe String)
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
frags <- (GBState -> [(CHSHook, CHSFrag)])
-> CT GBState [(CHSHook, CHSFrag)]
forall s a. (s -> a) -> CT s a
readCT GBState -> [(CHSHook, CHSFrag)]
frags
frags' <- delay hook frags
transCT (\GBState
state -> (GBState
state {frags = frags'}, ()))
where
newEntry :: (CHSHook, CHSFrag)
newEntry = (CHSHook
hook, (String -> Position -> CHSFrag
CHSVerb (String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str) (CHSHook -> Position
forall a. Pos a => a -> Position
posOf CHSHook
hook)))
delay :: CHSHook -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
delay hook :: CHSHook
hook@(CHSCall Bool
isFun Bool
isUns Bool
_ Ident
ide Maybe Ident
oalias Position
_) [(CHSHook, CHSFrag)]
frags =
case ((CHSHook, CHSFrag) -> Bool)
-> [(CHSHook, CHSFrag)] -> Maybe (CHSHook, CHSFrag)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(CHSHook
hook', CHSFrag
_) -> CHSHook
hook' CHSHook -> CHSHook -> Bool
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 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
isFun'
Bool -> Bool -> Bool
&& Bool
isUns Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
isUns'
Bool -> Bool -> Bool
&& Ident
ide Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide' -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
forall a. a -> PreCST SwitchBoard (CState GBState) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(CHSHook, CHSFrag)]
frags
| Bool
otherwise -> Position -> Position -> CT GBState [(CHSHook, CHSFrag)]
forall {a}. Position -> Position -> GB a
err (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide) (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide')
Maybe (CHSHook, CHSFrag)
Nothing -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
forall a. a -> PreCST SwitchBoard (CState GBState) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)])
-> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
forall a b. (a -> b) -> a -> b
$ [(CHSHook, CHSFrag)]
frags [(CHSHook, CHSFrag)]
-> [(CHSHook, CHSFrag)] -> [(CHSHook, CHSFrag)]
forall a. [a] -> [a] -> [a]
++ [(CHSHook, CHSFrag)
newEntry]
delay CHSHook
_ [(CHSHook, CHSFrag)]
_ =
String -> CT GBState [(CHSHook, CHSFrag)]
forall a. String -> a
interr String
"GBMonad.delayCode: Illegal delay!"
err :: Position -> Position -> GB a
err = Position -> Position -> GB a
forall {a}. Position -> Position -> GB a
incompatibleCallHooksErr
getDelayedCode :: GB [CHSFrag]
getDelayedCode :: GB [CHSFrag]
getDelayedCode = (GBState -> [CHSFrag]) -> GB [CHSFrag]
forall s a. (s -> a) -> CT s a
readCT (((CHSHook, CHSFrag) -> CHSFrag)
-> [(CHSHook, CHSFrag)] -> [CHSFrag]
forall a b. (a -> b) -> [a] -> [b]
map (CHSHook, CHSFrag) -> CHSFrag
forall a b. (a, b) -> b
snd ([(CHSHook, CHSFrag)] -> [CHSFrag])
-> (GBState -> [(CHSHook, CHSFrag)]) -> GBState -> [CHSFrag]
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 =
(GBState -> (GBState, ())) -> GB ()
forall s a. (s -> (s, a)) -> CT s a
transCT (\GBState
state -> (GBState
state {
ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state)
}, ()))
queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep)
queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep)
queryPtr (Bool, Ident)
pcName = do
fm <- (GBState -> PointerMap) -> CT GBState PointerMap
forall s a. (s -> a) -> CT s a
readCT GBState -> PointerMap
ptrmap
return $ Map.lookup pcName fm
objIs :: Ident -> HsObject -> GB ()
Ident
hsName objIs :: Ident -> HsObject -> GB ()
`objIs` HsObject
obj =
(GBState -> (GBState, ())) -> GB ()
forall s a. (s -> (s, a)) -> CT s a
transCT (\GBState
state -> (GBState
state {
objmap = Map.insert hsName obj (objmap state)
}, ()))
queryObj :: Ident -> GB (Maybe HsObject)
queryObj :: Ident -> GB (Maybe HsObject)
queryObj Ident
hsName = do
fm <- (GBState -> HsObjectMap) -> CT GBState HsObjectMap
forall s a. (s -> a) -> CT s a
readCT GBState -> HsObjectMap
objmap
return $ Map.lookup hsName fm
queryClass :: Ident -> GB HsObject
queryClass :: Ident -> GB HsObject
queryClass Ident
hsName = do
let pos :: Position
pos = Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
hsName
oobj <- Ident -> GB (Maybe HsObject)
queryObj Ident
hsName
case oobj of
Just obj :: HsObject
obj@(Class Maybe Ident
_ Ident
_) -> HsObject -> GB HsObject
forall a. a -> PreCST SwitchBoard (CState GBState) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsObject
obj
Just HsObject
_ -> Ident -> GB HsObject
forall a. Ident -> GB a
classExpectedErr Ident
hsName
Maybe HsObject
Nothing -> Ident -> GB HsObject
forall a. Ident -> GB a
hsObjExpectedErr Ident
hsName
queryPointer :: Ident -> GB HsObject
queryPointer :: Ident -> GB HsObject
queryPointer Ident
hsName = do
let pos :: Position
pos = Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
hsName
oobj <- Ident -> GB (Maybe HsObject)
queryObj Ident
hsName
case oobj of
Just obj :: HsObject
obj@(Pointer CHSPtrType
_ Bool
_) -> HsObject -> GB HsObject
forall a. a -> PreCST SwitchBoard (CState GBState) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsObject
obj
Just HsObject
_ -> Ident -> GB HsObject
forall a. Ident -> GB a
pointerExpectedErr Ident
hsName
Maybe HsObject
Nothing -> Ident -> GB HsObject
forall a. Ident -> GB a
hsObjExpectedErr Ident
hsName
mergeMaps :: String -> GB ()
mergeMaps :: String -> GB ()
mergeMaps String
str =
(GBState -> (GBState, ())) -> GB ()
forall s a. (s -> (s, a)) -> CT s a
transCT (\GBState
state -> (GBState
state {
ptrmap = Map.union (ptrmap state) readPtrMap,
objmap = Map.union (objmap state) readObjMap
}, ()))
where
([((Bool, String), HsPtrRep)]
ptrAssoc, [(String, HsObject)]
objAssoc) = String -> ([((Bool, String), HsPtrRep)], [(String, HsObject)])
forall a. Read a => String -> a
read String
str
readPtrMap :: PointerMap
readPtrMap = [((Bool, Ident), HsPtrRep)] -> PointerMap
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 = [(Ident, HsObject)] -> HsObjectMap
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
ptrFM <- (GBState -> PointerMap) -> CT GBState PointerMap
forall s a. (s -> a) -> CT s a
readCT GBState -> PointerMap
ptrmap
objFM <- readCT objmap
let dumpable = ([((Bool
isStar, TransFun
identToLexeme Ident
ide), HsPtrRep
repr)
| ((Bool
isStar, Ident
ide), HsPtrRep
repr) <- PointerMap -> [((Bool, Ident), HsPtrRep)]
forall k a. Map k a -> [(k, a)]
Map.toList PointerMap
ptrFM],
[(TransFun
identToLexeme Ident
ide, HsObject
obj)
| (Ident
ide, HsObject
obj) <- HsObjectMap -> [(Ident, HsObject)]
forall k a. Map k a -> [(k, a)]
Map.toList HsObjectMap
objFM])
return $ show dumpable
incompatibleCallHooksErr :: Position -> Position -> GB a
incompatibleCallHooksErr :: forall {a}. Position -> Position -> GB a
incompatibleCallHooksErr Position
here Position
there =
Position -> [String] -> CT GBState a
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
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 =
Position -> [String] -> CT GBState a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Expected a class name!",
String
"Expected `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TransFun
identToLexeme Ident
ide String -> String -> String
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 =
Position -> [String] -> CT GBState a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Expected a pointer name!",
String
"Expected `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TransFun
identToLexeme Ident
ide String -> String -> String
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 =
Position -> [String] -> CT GBState a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Unknown name!",
String
"`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TransFun
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is unknown; it has *not* been defined by",
String
"a previous hook."]