GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Make Ident abstract; imports of Data.ByteString.Char8 down from 29 to 16 modules

Browse Source 
Most of the explicit uses of ByteStrings were eliminated by using identS,

	identS = identC . BS.pack 

which was found in GF.Grammar.CF and moved to GF.Infra.Ident. The function

	prefixIdent :: String -> Ident -> Ident

allowed one additional import of ByteString to be eliminated. The functions

	isArgIdent :: Ident -> Bool
	getArgIndex :: Ident -> Maybe Int

were needed to eliminate explicit pattern matching on Ident from two modules.
This commit is contained in:
hallgren
2013-09-19 18:23:47 +00:00
parent 7bafc5653c
commit 38fe30c610
18 changed files with 101 additions and 237 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

@@ -16,14 +16,13 @@ module GF.Compile.Compute.AppPredefined (
isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined
) where
import GF.Infra.Ident
import GF.Infra.Ident(identS)
import GF.Infra.Option
import GF.Data.Operations
import GF.Grammar
import GF.Grammar.Predef
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
import Data.Char (isUpper,toUpper,toLower)
@@ -90,11 +89,8 @@ primitives = Map.fromList
fun from to = oper (mkFunType from to)
oper ty = ResOper (Just (noLoc ty)) Nothing
varL :: Ident
varL = identC (BS.pack "L")
varP :: Ident
varP = identC (BS.pack "P")
varL = identS "L"
varP = identS "P"
appPredefined :: Term -> Err (Term,Bool)
appPredefined t = case t of
@@ -127,7 +123,7 @@ appPredefined t = case t of
(EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
(EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
(_, t) | f == cShow && notVar t -> retb $ foldrC $ map K $ words $ render (ppTerm Unqualified 0 t)
(_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
(_, K s) | f == cRead -> retb $ Cn (identS s) --- because of K, only works for atomic tags
(_, t) | f == cToStr -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t

3
src/compiler/GF/Compile/Compute/ConcreteLazy.hs
View File

@@ -508,8 +508,7 @@ computeTermOpt gr = comput True where
-- | argument variables cannot be glued
checkNoArgVars :: Term -> Comp Term
checkNoArgVars t = case t of
Vr (IA _ _) -> fail $ glueErrorMsg $ ppTerm Unqualified 0 t
Vr (IAV _ _ _) -> fail $ glueErrorMsg $ ppTerm Unqualified 0 t
Vr x | isArgIdent x -> fail $ glueErrorMsg $ ppTerm Unqualified 0 t
_ -> composOp checkNoArgVars t
glueErrorMsg s =

5
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -19,7 +19,6 @@ import Control.Monad(ap,liftM,liftM2,mplus,unless)
import Data.List (findIndex,intersect,isInfixOf,nub,elemIndex,(\\))
import Data.Char (isUpper,toUpper,toLower)
import Text.PrettyPrint
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
--import Debug.Trace(trace)
@@ -80,7 +79,7 @@ resource env (m,c) =
resourceValues :: SourceGrammar -> GlobalEnv
resourceValues gr = env
where
env = GE gr rvs (L NoLoc IW)
env = GE gr rvs (L NoLoc identW)
rvs = Map.mapWithKey moduleResources (moduleMap gr)
moduleResources m = Map.mapWithKey (moduleResource m) . jments
moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
@@ -115,7 +114,7 @@ value env t0 =
Vr x -> var env x
Q x@(m,f)
| m == cPredef -> if f==cErrorType -- to be removed
then let p = identC (BS.pack "P")
then let p = identS "P"
in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
else const . flip VApp [] # predef f
| otherwise -> const # resource env x --valueResDef (fst env) x

3
src/compiler/GF/Compile/Compute/ConcreteNew1.hs
View File

@@ -9,7 +9,6 @@ import GF.Grammar.Predef
import GF.Data.Operations
import Data.List (intersect)
import Text.PrettyPrint
import qualified Data.ByteString.Char8 as BS
normalForm :: SourceGrammar -> Term -> Term
normalForm gr t = value2term gr [] (eval gr [] t)
@@ -44,7 +43,7 @@ eval gr env (Vr x) = case lookup x env of
Nothing -> error ("Unknown variable "++showIdent x)
eval gr env (Q x)
| x == (cPredef,cErrorType) -- to be removed
= let varP = identC (BS.pack "P")
= let varP = identS "P"
in eval gr [] (mkProd [(Implicit,varP,typeType)] (Vr varP) [])
| fst x == cPredef = VApp x []
| otherwise = case lookupResDef gr x of

7
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -32,7 +32,6 @@ import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint hiding (Str)
import Data.Array.IArray
import Data.Array.Unboxed
@@ -553,10 +552,8 @@ evalTerm path (EInt n) = return (EInt n)
evalTerm path t = ppbug (text "evalTerm" <+> parens (ppU 0 t))
--evalTerm path t = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
getVarIndex (IA _ i) = i
getVarIndex (IAV _ _ i) = i
getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd isDigit) s
getVarIndex x = bug ("getVarIndex "++show x)
getVarIndex x = maybe err id $ getArgIndex x
where err = bug ("getVarIndex "++show x)
----------------------------------------------------------------------
-- GrammarEnv

3
src/compiler/GF/Compile/Optimize.hs
View File

@@ -35,7 +35,6 @@ import Data.List
import qualified Data.Set as Set
import Text.PrettyPrint
import Debug.Trace
import qualified Data.ByteString.Char8 as BS
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
@@ -194,7 +193,7 @@ factor param c i t =
else V ty (map snd pvs0)
--- we hope this will be fresh and don't check... in GFC would be safe
qvar = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i))
qvar = identS ("q_" ++ showIdent c ++ "__" ++ show i)
mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val
mkCases t = [(PV qvar, t)]

7
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -13,7 +13,6 @@ import GF.Data.Operations
import Text.PrettyPrint
import Data.List (nub, (\\), tails)
import qualified Data.IntMap as IntMap
import qualified Data.ByteString.Char8 as BS
import GF.Grammar.Parser
import System.IO
@@ -438,8 +437,8 @@ quantify gr scope t tvs ty0 = do
bndrs _ = []
allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,...
allBinders = [ identC (BS.pack [x]) | x <- ['a'..'z'] ] ++
[ identC (BS.pack (x : show i)) | i <- [1 :: Integer ..], x <- ['a'..'z']]
allBinders = [ identS [x] | x <- ['a'..'z'] ] ++
[ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
-----------------------------------------------------------------------
@@ -502,7 +501,7 @@ setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)
newVar :: Scope -> Ident
newVar scope = head [x | i <- [1..],
let x = identC (BS.pack ('v':show i)),
let x = identS ('v':show i),
isFree scope x]
where
isFree [] x = True

2
src/compiler/GF/Compile/TypeCheck/TC.hs
View File

@@ -57,7 +57,7 @@ lookupConst :: Theory -> QIdent -> Err Val
lookupConst th f = th f
lookupVar :: Env -> Ident -> Err Val
lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((IW,uVal):g)
lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((identW,uVal):g)
-- wild card IW: no error produced, ?0 instead.
type TCEnv = (Int,Env,Env)

6
src/compiler/GF/Grammar/CF.hs
View File

@@ -16,7 +16,7 @@ module GF.Grammar.CF (getCF,CFItem,CFCat,CFFun,cf2gf,CFRule) where
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Infra.Ident
import GF.Infra.Ident(Ident,identS)
import GF.Infra.Option
import GF.Infra.UseIO
@@ -25,7 +25,6 @@ import GF.Data.Utilities (nub')
import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as BS
import System.FilePath
getCF :: FilePath -> String -> Err SourceGrammar
@@ -126,6 +125,3 @@ cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
mkIt (_, Right a) = K a
foldconcat [] = K ""
foldconcat tt = foldr1 C tt
identS = identC . BS.pack

2
src/compiler/GF/Grammar/MMacros.hs
View File

@@ -215,7 +215,7 @@ freeVarsExp e = case e of
_ -> [] --- thus applies to abstract syntax only
int2var :: Int -> Ident
int2var = identC . BS.pack . ('$':) . show
int2var = identS . ('$':) . show
meta0 :: MetaId
meta0 = 0

10
src/compiler/GF/Grammar/Parser.y
View File

@@ -16,7 +16,6 @@ import GF.Grammar.Predef
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Grammar.Lexer
import qualified Data.ByteString.Char8 as BS
import GF.Compile.Update (buildAnyTree)
import Codec.Binary.UTF8.String(decodeString)
import Data.Char(toLower)
@@ -622,12 +621,9 @@ optDecode opts =
else id
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixId (BS.pack "List")
mkConsId = prefixId (BS.pack "Cons")
mkBaseId = prefixId (BS.pack "Base")
prefixId :: BS.ByteString -> Ident -> Ident
prefixId pref id = identC (BS.append pref (ident2bs id))
mkListId = prefixIdent "List"
mkConsId = prefixIdent "Cons"
mkBaseId = prefixIdent "Base"
listCatDef :: L (Ident, Context, Int) -> [(Ident,Info)]
listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]

238
src/compiler/GF/Grammar/Predef.hs
View File

@@ -8,195 +8,65 @@
-- Predefined identifiers and labels which the compiler knows
----------------------------------------------------------------------
module GF.Grammar.Predef where
module GF.Grammar.Predef
( cType
, cPType
, cTok
, cStr
, cStrs
, cPredefAbs, cPredefCnc, cPredef
, cInt
, cFloat
, cString
, cVar
, cInts
, cNonExist
, cPBool
, cErrorType
, cOverload
, cUndefinedType
, isPredefCat
import GF.Infra.Ident(Ident,identS)
, cPTrue, cPFalse
, cLength, cDrop, cTake, cTk, cDp, cEqStr, cOccur
, cOccurs, cEqInt, cLessInt, cPlus, cShow, cRead
, cToStr, cMapStr, cError
, cToUpper, cToLower, cIsUpper
, cEqVal
-- hacks
, cMeta, cAs, cChar, cChars, cSeq, cAlt, cRep
, cNeg, cCNC, cConflict
) where
import GF.Infra.Ident
import qualified Data.ByteString.Char8 as BS
cType :: Ident
cType = identC (BS.pack "Type")
cPType :: Ident
cPType = identC (BS.pack "PType")
cTok :: Ident
cTok = identC (BS.pack "Tok")
cStr :: Ident
cStr = identC (BS.pack "Str")
cStrs :: Ident
cStrs = identC (BS.pack "Strs")
cPredefAbs :: Ident
cPredefAbs = identC (BS.pack "PredefAbs")
cPredefCnc :: Ident
cPredefCnc = identC (BS.pack "PredefCnc")
cPredef :: Ident
cPredef = identC (BS.pack "Predef")
cInt :: Ident
cInt = identC (BS.pack "Int")
cFloat :: Ident
cFloat = identC (BS.pack "Float")
cString :: Ident
cString = identC (BS.pack "String")
cVar :: Ident
cVar = identC (BS.pack "__gfVar")
cInts :: Ident
cInts = identC (BS.pack "Ints")
cPBool :: Ident
cPBool = identC (BS.pack "PBool")
cErrorType :: Ident
cErrorType = identC (BS.pack "Error")
cOverload :: Ident
cOverload = identC (BS.pack "overload")
cUndefinedType :: Ident
cUndefinedType = identC (BS.pack "UndefinedType")
cNonExist :: Ident
cNonExist = identC (BS.pack "nonExist")
cType = identS "Type"
cPType = identS "PType"
cTok = identS "Tok"
cStr = identS "Str"
cStrs = identS "Strs"
cPredefAbs = identS "PredefAbs"
cPredefCnc = identS "PredefCnc"
cPredef = identS "Predef"
cInt = identS "Int"
cFloat = identS "Float"
cString = identS "String"
cVar = identS "__gfVar"
cInts = identS "Ints"
cPBool = identS "PBool"
cErrorType = identS "Error"
cOverload = identS "overload"
cUndefinedType = identS "UndefinedType"
cNonExist = identS "nonExist"
isPredefCat :: Ident -> Bool
isPredefCat c = elem c [cInt,cString,cFloat]
cPTrue :: Ident
cPTrue = identC (BS.pack "PTrue")
cPTrue = identS "PTrue"
cPFalse = identS "PFalse"
cLength = identS "length"
cDrop = identS "drop"
cTake = identS "take"
cTk = identS "tk"
cDp = identS "dp"
cToUpper = identS "toUpper"
cToLower = identS "toLower"
cIsUpper = identS "isUpper"
cEqStr = identS "eqStr"
cEqVal = identS "eqVal"
cOccur = identS "occur"
cOccurs = identS "occurs"
cEqInt = identS "eqInt"
cLessInt = identS "lessInt"
cPlus = identS "plus"
cShow = identS "show"
cRead = identS "read"
cToStr = identS "toStr"
cMapStr = identS "mapStr"
cError = identS "error"
cPFalse :: Ident
cPFalse = identC (BS.pack "PFalse")
-- * Hacks: dummy identifiers used in various places.
-- Not very nice!
cLength :: Ident
cLength = identC (BS.pack "length")
cDrop :: Ident
cDrop = identC (BS.pack "drop")
cTake :: Ident
cTake = identC (BS.pack "take")
cTk :: Ident
cTk = identC (BS.pack "tk")
cDp :: Ident
cDp = identC (BS.pack "dp")
cToUpper :: Ident
cToUpper = identC (BS.pack "toUpper")
cToLower :: Ident
cToLower = identC (BS.pack "toLower")
cIsUpper :: Ident
cIsUpper = identC (BS.pack "isUpper")
cEqStr :: Ident
cEqStr = identC (BS.pack "eqStr")
cEqVal :: Ident
cEqVal = identC (BS.pack "eqVal")
cOccur :: Ident
cOccur = identC (BS.pack "occur")
cOccurs :: Ident
cOccurs = identC (BS.pack "occurs")
cEqInt :: Ident
cEqInt = identC (BS.pack "eqInt")
cLessInt :: Ident
cLessInt = identC (BS.pack "lessInt")
cPlus :: Ident
cPlus = identC (BS.pack "plus")
cShow :: Ident
cShow = identC (BS.pack "show")
cRead :: Ident
cRead = identC (BS.pack "read")
cToStr :: Ident
cToStr = identC (BS.pack "toStr")
cMapStr :: Ident
cMapStr = identC (BS.pack "mapStr")
cError :: Ident
cError = identC (BS.pack "error")
--- hacks: dummy identifiers used in various places
--- Not very nice!
cMeta :: Ident
cMeta = identC (BS.singleton '?')
cAs :: Ident
cAs = identC (BS.singleton '@')
cChar :: Ident
cChar = identC (BS.singleton '?')
cChars :: Ident
cChars = identC (BS.pack "[]")
cSeq :: Ident
cSeq = identC (BS.pack "+")
cAlt :: Ident
cAlt = identC (BS.pack "|")
cRep :: Ident
cRep = identC (BS.pack "*")
cNeg :: Ident
cNeg = identC (BS.pack "-")
cCNC :: Ident
cCNC = identC (BS.pack "CNC")
cConflict :: Ident
cConflict = IC (BS.pack "#conflict")
cMeta = identS "?"
cAs = identS "@"
cChar = identS "?"
cChars = identS "[]"
cSeq = identS "+"
cAlt = identS "|"
cRep = identS "*"
cNeg = identS "-"
cCNC = identS "CNC"
cConflict = identS "#conflict"

25
src/compiler/GF/Infra/Ident.hs
View File

@@ -13,9 +13,10 @@
-----------------------------------------------------------------------------
module GF.Infra.Ident (-- * Identifiers
Ident(..), ident2bs, showIdent, ppIdent,
identC, identV, identA, identAV, identW,
argIdent, varStr, varX, isWildIdent, varIndex,
Ident, ident2bs, showIdent, ppIdent, prefixIdent,
identS, identC, identV, identA, identAV, identW,
argIdent, isArgIdent, getArgIndex,
varStr, varX, isWildIdent, varIndex,
-- * refreshing identifiers
IdState, initIdStateN, initIdState,
lookVar, refVar, refVarPlus
@@ -23,6 +24,7 @@ module GF.Infra.Ident (-- * Identifiers
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
import Data.Char(isDigit)
import Text.PrettyPrint
@@ -54,6 +56,9 @@ showIdent i = BS.unpack $! ident2bs i
ppIdent :: Ident -> Doc
ppIdent = text . showIdent
identS :: String -> Ident
identS = identC . BS.pack
identC :: BS.ByteString -> Ident
identV :: BS.ByteString -> Int -> Ident
identA :: BS.ByteString -> Int -> Ident
@@ -62,6 +67,10 @@ identW :: Ident
(identC, identV, identA, identAV, identW) =
(IC, IV, IA, IAV, IW)
prefixIdent :: String -> Ident -> Ident
prefixIdent pref = identC . BS.append (BS.pack pref) . ident2bs
-- normal identifier
-- ident s = IC s
@@ -70,6 +79,16 @@ argIdent :: Int -> Ident -> Int -> Ident
argIdent 0 (IC c) i = identA c i
argIdent b (IC c) i = identAV c b i
isArgIdent IA{} = True
isArgIdent IAV{} = True
isArgIdent _ = False
getArgIndex (IA _ i) = Just i
getArgIndex (IAV _ _ i) = Just i
getArgIndex (IC s)
| isDigit (BS.last s) = (Just . read . BS.unpack . snd . BS.spanEnd isDigit) s
getArgIndex x = Nothing
-- | used in lin defaults
varStr :: Ident
varStr = identA (BS.pack "str") 0

4
src/compiler/GF/Infra/Option.hs
View File

@@ -42,8 +42,6 @@ import GF.Data.ErrM
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
usageHeader :: String
@@ -398,7 +396,7 @@ optDescr =
Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) }
Nothing -> fail $ "Unknown Haskell option: " ++ x
++ " Known: " ++ show (map fst haskellOptionNames)
literalCat x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map (identC . BS.pack) . splitBy (==',')) x) }
literalCat x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
outDir x = set $ \o -> o { optOutputDir = Just x }
gfLibPath x = set $ \o -> o { optGFLibPath = Just x }

1
src/compiler/GF/Infra/UseIO.hs
View File

@@ -34,7 +34,6 @@ import Text.Printf
import Control.Monad
import Control.Monad.Trans(MonadIO(..))
import Control.Exception(evaluate)
import qualified Data.ByteString.Char8 as BS
putShow' :: Show a => (c -> a) -> c -> IO ()
putShow' f = putStrLn . show . length . show . f

1
src/compiler/GF/Speech/CFG.hs
View File

@@ -13,7 +13,6 @@ import GF.Data.Relation
import Control.Monad
import Control.Monad.State (State, get, put, evalState)
import qualified Data.ByteString.Char8 as BS
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List

7
src/compiler/GFC.hs
View File

@@ -10,7 +10,7 @@ import GF.Compile
import GF.Compile.Export
import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008
import GF.Grammar (identC)
import GF.Infra.Ident(identS)
import GF.Infra.UseIO
import GF.Infra.Option
@@ -21,7 +21,6 @@ import Data.Binary
import qualified Data.Map as Map
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Char8 as BS
import System.FilePath
import System.IO
import Control.Exception
@@ -49,7 +48,7 @@ compileSourceFiles opts fs =
let cnc = justModuleName (last fs)
if flag optStopAfterPhase opts == Compile
then return ()
else do pgf <- link opts (identC (BS.pack cnc)) gr
else do pgf <- link opts (identS cnc) gr
writePGF opts pgf
writeByteCode opts pgf
writeOutputs opts pgf
@@ -62,7 +61,7 @@ compileCFFiles opts fs =
gr <- compileSourceGrammar opts gf
if flag optStopAfterPhase opts == Compile
then return ()
else do pgf <- link opts (identC (BS.pack cnc)) gr
else do pgf <- link opts (identS cnc) gr
writePGF opts pgf
writeOutputs opts pgf

2
src/compiler/GFI.hs
View File

@@ -333,7 +333,7 @@ checkComputeTerm' new sgr t = do
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
t1 <- if new
then return (CN.normalForm (CN.resourceValues sgr) (L NoLoc IW) t)
then return (CN.normalForm (CN.resourceValues sgr) (L NoLoc identW) t)
else computeConcrete sgr t
checkPredefError sgr t1