----------------------------------------------------------------------
-- |
-- Module      : Lockfield
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:34 $ 
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- Creating and using lock fields in reused resource grammars.
--
-- AR 8\/2\/2005 detached from 'compile/MkResource'
-----------------------------------------------------------------------------

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 --- don't add an extra copy of lock field, nor predef cats
    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_"