mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-08 02:32:50 -06:00
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
253
src-3.0/GF/CF/CFIdent.hs
Normal file
253
src-3.0/GF/CF/CFIdent.hs
Normal file
@@ -0,0 +1,253 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : CFIdent
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/14 16:03:40 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.13 $
|
||||
--
|
||||
-- symbols (categories, functions) for context-free grammars.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.CF.CFIdent (-- * Tokens and categories
|
||||
CFTok(..), CFCat(..),
|
||||
tS, tC, tL, tI, tF, tV, tM, tInt,
|
||||
prCFTok,
|
||||
-- * Function names and profiles
|
||||
CFFun(..), Profile,
|
||||
wordsCFTok,
|
||||
-- * CF Functions
|
||||
mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun,
|
||||
intCFFun, floatCFFun, dummyCFFun,
|
||||
cfFun2String, cfFun2Ident, cfFun2Profile, metaCFFun,
|
||||
-- * CF Categories
|
||||
mkCIdent, ident2CFCat, labels2CFCat, string2CFCat,
|
||||
catVarCF, cat2CFCat, cfCatString, cfCatInt,cfCatFloat,
|
||||
moduleOfCFCat, cfCat2Cat, cfCat2Ident, lexCFCat,
|
||||
-- * CF Tokens
|
||||
string2CFTok, str2cftoks,
|
||||
-- * Comparisons
|
||||
compatToks, compatTok, compatCFFun, compatCF,
|
||||
wordsLits
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Canon.GFC
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Values (cPredefAbs)
|
||||
import GF.Canon.AbsGFC
|
||||
import GF.Grammar.Macros (ident2label)
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Data.Str
|
||||
import Data.Char (toLower, toUpper, isSpace)
|
||||
import Data.List (intersperse)
|
||||
|
||||
-- | this type should be abstract
|
||||
data CFTok =
|
||||
TS String -- ^ normal strings
|
||||
| TC String -- ^ strings that are ambiguous between upper or lower case
|
||||
| TL String -- ^ string literals
|
||||
| TI Integer -- ^ integer literals
|
||||
| TF Double -- ^ float literals
|
||||
| TV Ident -- ^ variables
|
||||
| TM Int String -- ^ metavariables; the integer identifies it
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | this type should be abstract
|
||||
newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show)
|
||||
|
||||
tS :: String -> CFTok
|
||||
tC :: String -> CFTok
|
||||
tL :: String -> CFTok
|
||||
tI :: String -> CFTok
|
||||
tF :: String -> CFTok
|
||||
tV :: String -> CFTok
|
||||
tM :: String -> CFTok
|
||||
|
||||
tS = TS
|
||||
tC = TC
|
||||
tL = TL
|
||||
tI = TI . read
|
||||
tF = TF . read
|
||||
tV = TV . identC
|
||||
tM = TM 0
|
||||
|
||||
tInt :: Integer -> CFTok
|
||||
tInt = TI
|
||||
|
||||
prCFTok :: CFTok -> String
|
||||
prCFTok t = case t of
|
||||
TS s -> s
|
||||
TC s -> s
|
||||
TL s -> s
|
||||
TI i -> show i
|
||||
TF i -> show i
|
||||
TV x -> prt x
|
||||
TM i m -> m --- "?" --- m
|
||||
|
||||
-- | to build trees: the Atom contains a GF function, @Cn | Meta | Vr | Literal@
|
||||
newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Ord,Show)
|
||||
-- - - - - - - - - - - - - - - - - - - - - ^^^ added by peb, 21/5-04
|
||||
|
||||
type Profile = [([[Int]],[Int])]
|
||||
|
||||
wordsCFTok :: CFTok -> [String]
|
||||
wordsCFTok t = case t of
|
||||
TC (c:cs) -> [c':cs | c' <- [toUpper c, toLower c]]
|
||||
_ -> [prCFTok t]
|
||||
|
||||
-- the following functions should be used instead of constructors
|
||||
|
||||
-- to construct CF functions
|
||||
|
||||
mkCFFun :: Atom -> CFFun
|
||||
mkCFFun t = CFFun (t,[])
|
||||
|
||||
varCFFun :: Ident -> CFFun
|
||||
varCFFun = mkCFFun . AV
|
||||
|
||||
consCFFun :: CIdent -> CFFun
|
||||
consCFFun = mkCFFun . AC
|
||||
|
||||
-- | standard way of making cf fun
|
||||
string2CFFun :: String -> String -> CFFun
|
||||
string2CFFun m c = consCFFun $ mkCIdent m c
|
||||
|
||||
stringCFFun :: String -> CFFun
|
||||
stringCFFun = mkCFFun . AS
|
||||
|
||||
intCFFun :: Integer -> CFFun
|
||||
intCFFun = mkCFFun . AI
|
||||
|
||||
floatCFFun :: Double -> CFFun
|
||||
floatCFFun = mkCFFun . AF
|
||||
|
||||
-- | used in lexer-by-need rules
|
||||
dummyCFFun :: CFFun
|
||||
dummyCFFun = varCFFun $ identC "_"
|
||||
|
||||
cfFun2String :: CFFun -> String
|
||||
cfFun2String (CFFun (f,_)) = prt f
|
||||
|
||||
cfFun2Ident :: CFFun -> Ident
|
||||
cfFun2Ident (CFFun (f,_)) = identC $ prt_ f ---
|
||||
|
||||
cfFun2Profile :: CFFun -> Profile
|
||||
cfFun2Profile (CFFun (_,p)) = p
|
||||
|
||||
{- ----
|
||||
strPro2cfFun :: String -> Profile -> CFFun
|
||||
strPro2cfFun str p = (CFFun (AC (Ident str), p))
|
||||
-}
|
||||
|
||||
metaCFFun :: CFFun
|
||||
metaCFFun = mkCFFun $ AM 0
|
||||
|
||||
-- to construct CF categories
|
||||
|
||||
-- | belongs elsewhere
|
||||
mkCIdent :: String -> String -> CIdent
|
||||
mkCIdent m c = CIQ (identC m) (identC c)
|
||||
|
||||
ident2CFCat :: CIdent -> Ident -> CFCat
|
||||
ident2CFCat mc d = CFCat (mc, L d)
|
||||
|
||||
labels2CFCat :: CIdent -> [Label] -> CFCat
|
||||
labels2CFCat mc d = CFCat (mc, L (identC (concat (intersperse "." (map prt d))))) ----
|
||||
|
||||
-- | standard way of making cf cat: label s
|
||||
string2CFCat :: String -> String -> CFCat
|
||||
string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s")
|
||||
|
||||
idents2CFCat :: Ident -> Ident -> CFCat
|
||||
idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s")
|
||||
|
||||
catVarCF :: CFCat
|
||||
catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ----
|
||||
|
||||
cat2CFCat :: (Ident,Ident) -> CFCat
|
||||
cat2CFCat = uncurry idents2CFCat
|
||||
|
||||
-- | literals
|
||||
cfCatString :: CFCat
|
||||
cfCatString = string2CFCat (prt cPredefAbs) "String"
|
||||
|
||||
cfCatInt, cfCatFloat :: CFCat
|
||||
cfCatInt = string2CFCat (prt cPredefAbs) "Int"
|
||||
cfCatFloat = string2CFCat (prt cPredefAbs) "Float"
|
||||
|
||||
|
||||
|
||||
{- ----
|
||||
uCFCat :: CFCat
|
||||
uCFCat = cat2CFCat uCat
|
||||
-}
|
||||
|
||||
moduleOfCFCat :: CFCat -> Ident
|
||||
moduleOfCFCat (CFCat (CIQ m _, _)) = m
|
||||
|
||||
-- | the opposite direction
|
||||
cfCat2Cat :: CFCat -> (Ident,Ident)
|
||||
cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
|
||||
|
||||
cfCat2Ident :: CFCat -> Ident
|
||||
cfCat2Ident = snd . cfCat2Cat
|
||||
|
||||
lexCFCat :: CFCat -> CFCat
|
||||
lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*")
|
||||
|
||||
-- to construct CF tokens
|
||||
|
||||
string2CFTok :: String -> CFTok
|
||||
string2CFTok = tS
|
||||
|
||||
str2cftoks :: Str -> [CFTok]
|
||||
str2cftoks = map tS . wordsLits . sstr
|
||||
|
||||
-- decide if two token lists look the same (in parser postprocessing)
|
||||
|
||||
compatToks :: [CFTok] -> [CFTok] -> Bool
|
||||
compatToks ts us = and [compatTok t u | (t,u) <- zip ts us]
|
||||
|
||||
compatTok :: CFTok -> CFTok -> Bool
|
||||
compatTok (TM _ _) _ = True --- hack because metas are renamed
|
||||
compatTok _ (TM _ _) = True
|
||||
compatTok t u = any (`elem` (alts t)) (alts u) where
|
||||
alts u = case u of
|
||||
TC (c:s) -> [toLower c : s, toUpper c : s]
|
||||
TL s -> [s, prQuotedString s]
|
||||
_ -> [prCFTok u]
|
||||
|
||||
-- | decide if two CFFuns have the same function head (profiles may differ)
|
||||
compatCFFun :: CFFun -> CFFun -> Bool
|
||||
compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g
|
||||
|
||||
-- | decide whether two categories match
|
||||
-- the modifiers can be from different modules, but on the same extension
|
||||
-- path, so there is no clash, and they can be safely ignored ---
|
||||
compatCF :: CFCat -> CFCat -> Bool
|
||||
----compatCF = (==)
|
||||
compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l'
|
||||
|
||||
-- | Like 'words', but does not split on whitespace inside
|
||||
-- double quotes.wordsLits :: String -> [String]
|
||||
-- Also treats escaped quotes in quotes (AR 21/12/2005) by breaks
|
||||
-- instead of break
|
||||
wordsLits [] = []
|
||||
wordsLits (c:cs) | isSpace c = wordsLits (dropWhile isSpace cs)
|
||||
| isQuote c
|
||||
= let (l,rs) = breaks (==c) cs
|
||||
rs' = drop 1 rs
|
||||
in ([c]++l++[c]):wordsLits rs'
|
||||
| otherwise = let (w,rs) = break isSpaceQ cs
|
||||
in (c:w):wordsLits rs
|
||||
where
|
||||
breaks c cs = case break c cs of
|
||||
(l@(_:_),d:rs) | last l == '\\' ->
|
||||
let (r,ts) = breaks c rs in (l++[d]++r, ts)
|
||||
v -> v
|
||||
isQuote c = elem c "\"'"
|
||||
isSpaceQ c = isSpace c ---- || isQuote c
|
||||
Reference in New Issue
Block a user