module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Data.Operations(ErrorMonad,Err(..))
lockRecType :: ErrorMonad m => Ident -> Type -> m Type
lockRecType :: Ident -> Type -> m Type
lockRecType Ident
c t :: Type
t@(RecType [Labelling]
rs) =
let lab :: Label
lab = Ident -> Label
lockLabel Ident
c in
Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ if Label -> [Label] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Label
lab ((Labelling -> Label) -> [Labelling] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Labelling -> Label
forall a b. (a, b) -> a
fst [Labelling]
rs) Bool -> Bool -> Bool
|| String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Ident -> String
showIdent Ident
c) [String
"String",String
"Int"]
then Type
t
else [Labelling] -> Type
RecType ([Labelling]
rs [Labelling] -> [Labelling] -> [Labelling]
forall a. [a] -> [a] -> [a]
++ [(Ident -> Label
lockLabel Ident
c, [Labelling] -> Type
RecType [])])
lockRecType Ident
c Type
t = Type -> Type -> m Type
forall (m :: * -> *). ErrorMonad m => Type -> Type -> m Type
plusRecType Type
t (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ [Labelling] -> Type
RecType [(Ident -> Label
lockLabel Ident
c, [Labelling] -> Type
RecType [])]
unlockRecord :: Monad m => Ident -> Term -> m Term
unlockRecord :: Ident -> Type -> m Type
unlockRecord Ident
c Type
ft = do
let ([(BindType, Ident)]
xs,Type
t) = Type -> ([(BindType, Ident)], Type)
termFormCnc Type
ft
let lock :: Type
lock = [Assign] -> Type
R [(Ident -> Label
lockLabel Ident
c, (Type -> Maybe Type
forall a. a -> Maybe a
Just ([Labelling] -> Type
RecType []),[Assign] -> Type
R []))]
case Type -> Type -> Err Type
forall (m :: * -> *). ErrorMonad m => Type -> Type -> m Type
plusRecord Type
t Type
lock of
Ok Type
t' -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ [(BindType, Ident)] -> Type -> Type
mkAbs [(BindType, Ident)]
xs Type
t'
Err Type
_ -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ [(BindType, Ident)] -> Type -> Type
mkAbs [(BindType, Ident)]
xs (Type -> Type -> Type
ExtR Type
t Type
lock)
lockLabel :: Ident -> Label
lockLabel :: Ident -> Label
lockLabel Ident
c = RawIdent -> Label
LIdent (RawIdent -> Label) -> RawIdent -> Label
forall a b. (a -> b) -> a -> b
$! RawIdent -> RawIdent -> RawIdent
prefixRawIdent RawIdent
lockPrefix (Ident -> RawIdent
ident2raw Ident
c)
isLockLabel :: Label -> Bool
isLockLabel :: Label -> Bool
isLockLabel Label
l = case Label
l of
LIdent RawIdent
c -> RawIdent -> RawIdent -> Bool
isPrefixOf RawIdent
lockPrefix RawIdent
c
Label
_ -> Bool
False
lockPrefix :: RawIdent
lockPrefix = String -> RawIdent
rawIdentS String
"lock_"