mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-17 15:12:50 -06:00
018c9838ed
+ Eliminated vairous ad-hoc coersion functions between specific monads (IO, Err, IOE, Check) in favor of more general lifting functions (liftIO, liftErr). + Generalized many basic monadic operations from specific monads to arbitrary monads in the appropriate class (MonadIO and/or ErrorMonad), thereby completely eliminating the need for lifting functions in lots of places. This can be considered a small step forward towards a cleaner compiler API and more malleable compiler code in general.
51 lines
1.5 KiB
Haskell
51 lines
1.5 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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 c t@(RecType rs) =
|
|
let lab = lockLabel c in
|
|
return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
|
|
then t --- don't add an extra copy of lock field, nor predef cats
|
|
else RecType (rs ++ [(lockLabel c, RecType [])])
|
|
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]
|
|
|
|
unlockRecord :: Monad m => Ident -> Term -> m Term
|
|
unlockRecord c ft = do
|
|
let (xs,t) = termFormCnc ft
|
|
let lock = R [(lockLabel c, (Just (RecType []),R []))]
|
|
case plusRecord t lock of
|
|
Ok t' -> return $ mkAbs xs t'
|
|
_ -> return $ mkAbs xs (ExtR t lock)
|
|
|
|
lockLabel :: Ident -> Label
|
|
lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
|
|
|
|
isLockLabel :: Label -> Bool
|
|
isLockLabel l = case l of
|
|
LIdent c -> isPrefixOf lockPrefix c
|
|
_ -> False
|
|
|
|
|
|
lockPrefix = rawIdentS "lock_"
|