GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-27 11:48:55 -06:00
Code Issues Packages Projects Releases Wiki Activity

Make GF.Grammar.Canonical.Id a type synonym for GF.Infra.Ident.RawIdent

Browse Source 
This avoids a lot of conversion back and forth between Strings and ByteStrings
This commit is contained in:
John J. Camilleri
2021-04-06 22:15:07 +02:00
parent f7df62a445
commit d0c27cdaae
7 changed files with 101 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -7,7 +7,7 @@ import GF.Text.Pretty
--import GF.Grammar.Predef(cPredef,cInts) --import GF.Grammar.Predef(cPredef,cInts)
--import GF.Compile.Compute.Predef(predef) --import GF.Compile.Compute.Predef(predef)
--import GF.Compile.Compute.Value(Predefined(..)) --import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(Ident,identS,identW,prefixIdent) import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
import GF.Infra.Option import GF.Infra.Option
import GF.Haskell as H import GF.Haskell as H
import GF.Grammar.Canonical as C import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
| let Grammar abstr cncs = grammar2canonical opts absname gr, | let Grammar abstr cncs = grammar2canonical opts absname gr,
cncmod<-cncs, cncmod<-cncs,
let ModId name = concName cncmod let ModId name = concName cncmod
filename = name ++ ".hs" :: FilePath filename = showRawIdent name ++ ".hs" :: FilePath
] ]
-- | Generate Haskell code for the given concrete module. -- | Generate Haskell code for the given concrete module.
@@ -53,7 +53,7 @@ concrete2haskell opts
labels = S.difference (S.unions (map S.fromList recs)) common_labels labels = S.difference (S.unions (map S.fromList recs)) common_labels
common_records = S.fromList [[label_s]] common_records = S.fromList [[label_s]]
common_labels = S.fromList [label_s] common_labels = S.fromList [label_s]
label_s = LabelId "s" label_s = LabelId (rawIdentS "s")
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin)) signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
where where
@@ -334,18 +334,17 @@ coerce env ty t =
_ -> t _ -> t
where where
app f ts = ParamConstant (Param f ts) -- !! a hack app f ts = ParamConstant (Param f ts) -- !! a hack
to_rcon = ParamId . Unqual . to_rcon' . labels to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
patVars p = [] patVars p = []
labels r = [l | RecordRow l _ <- r] labels r = [l | RecordRow l _ <- r]
proj = Var . identS . proj' proj = Var . identS . proj'
proj' (LabelId l) = "proj_"++l proj' (LabelId l) = "proj_" ++ showRawIdent l
rcon = Var . rcon' rcon = Var . rcon'
rcon' = identS . rcon_name rcon' = identS . rcon_name
rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls]) rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
to_rcon' = ("to_"++) . rcon_name to_rcon' = ("to_"++) . rcon_name
recordType ls = recordType ls =
@@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
instance ToIdent PredefId where toIdent (PredefId s) = identS s instance ToIdent PredefId where toIdent (PredefId s) = identC s
instance ToIdent CatId where toIdent (CatId s) = identS s instance ToIdent CatId where toIdent (CatId s) = identC s
instance ToIdent C.FunId where toIdent (FunId s) = identS s instance ToIdent C.FunId where toIdent (FunId s) = identC s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
qIdentS = identS . unqual qIdentC = identS . unqual
unqual (Qual (ModId m) n) = m++"_"++n unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
unqual (Unqual n) = n unqual (Unqual n) = showRawIdent n
instance ToIdent VarId where instance ToIdent VarId where
toIdent Anonymous = identW toIdent Anonymous = identW
toIdent (VarId s) = identS s toIdent (VarId s) = identC s

24
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -16,7 +16,7 @@ import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts) import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef) import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..)) import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,prefixIdent,showIdent,isWildIdent)
import GF.Infra.Option(Options, optionsPGF) import GF.Infra.Option(Options, optionsPGF)
import PGF.Internal(Literal(..)) import PGF.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
@@ -189,7 +189,7 @@ convert' gr vs = ppT
Ok ALL_CAPIT -> p "ALL_CAPIT" Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gQId cPredef n) -- hmm _ -> VarValue (gQId cPredef n) -- hmm
where where
p = PredefValue . PredefId p = PredefValue . PredefId . rawIdentS
ppP p = ppP p =
case p of case p of
@@ -358,16 +358,20 @@ paramType gr q@(_,n) =
argTypes = S.unions . map argTypes1 argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
lblId = LabelId . render -- hmm lblId :: Label -> C.LabelId
modId (MN m) = ModId (showIdent m) lblId (LIdent ri) = LabelId ri
lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
modId :: ModuleName -> C.ModId
modId (MN m) = ModId (ident2raw m)
class FromIdent i where gId :: Ident -> i class FromIdent i where gId :: Ident -> i
instance FromIdent VarId where instance FromIdent VarId where
gId i = if isWildIdent i then Anonymous else VarId (showIdent i) gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
instance FromIdent C.FunId where gId = C.FunId . showIdent instance FromIdent C.FunId where gId = C.FunId . ident2raw
instance FromIdent CatId where gId = CatId . showIdent instance FromIdent CatId where gId = CatId . ident2raw
instance FromIdent ParamId where gId = ParamId . unqual instance FromIdent ParamId where gId = ParamId . unqual
instance FromIdent VarValueId where gId = VarValueId . unqual instance FromIdent VarValueId where gId = VarValueId . unqual
@@ -376,11 +380,11 @@ class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
instance QualIdent ParamId where gQId m n = ParamId (qual m n) instance QualIdent ParamId where gQId m n = ParamId (qual m n)
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n) instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
qual m n = Qual (modId m) (showIdent n) qual m n = Qual (modId m) (ident2raw n)
unqual n = Unqual (showIdent n) unqual n = Unqual (ident2raw n)
convFlags gr mn = convFlags gr mn =
Flags [(n,convLit v) | Flags [(rawIdentS n,convLit v) |
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
where where
convLit l = convLit l =

23
src/compiler/GF/Compile/GrammarToLPGF.hs
View File

@@ -10,6 +10,7 @@ import GF.Compile.GrammarToCanonical (grammar2canonical)
import GF.Data.Operations (ErrorMonad (..)) import GF.Data.Operations (ErrorMonad (..))
import qualified GF.Data.IntMapBuilder as IntMapBuilder import qualified GF.Data.IntMapBuilder as IntMapBuilder
import GF.Infra.Ident (rawIdentS, showRawIdent)
import GF.Infra.Option (Options) import GF.Infra.Option (Options)
import GF.Infra.UseIO (IOE) import GF.Infra.UseIO (IOE)
import GF.Text.Pretty (pp, render) import GF.Text.Pretty (pp, render)
@@ -63,10 +64,10 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
lincats :: [C.LincatDef] lincats :: [C.LincatDef]
lincats = s:i:f:lincats0 lincats = s:i:f:lincats0
where where
ss = C.RecordType [C.RecordRow (C.LabelId "s") C.StrType] ss = C.RecordType [C.RecordRow (C.LabelId (rawIdentS "s")) C.StrType]
s = C.LincatDef (C.CatId "String") ss s = C.LincatDef (C.CatId (rawIdentS "String")) ss
i = C.LincatDef (C.CatId "Int") ss i = C.LincatDef (C.CatId (rawIdentS "Int")) ss
f = C.LincatDef (C.CatId "Float") ss f = C.LincatDef (C.CatId (rawIdentS "Float")) ss
lindefs :: [C.LinDef] lindefs :: [C.LinDef]
lindefs = lindefs =
@@ -108,7 +109,7 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
Just d -> Right d Just d -> Right d
Nothing -> Nothing ->
-- Left $ printf "Cannot find param definition: %s" (show pid) -- Left $ printf "Cannot find param definition: %s" (show pid)
Right $ C.ParamDef (C.ParamId (C.Unqual "DUMMY")) [C.Param pid []] Right $ C.ParamDef (C.ParamId (C.Unqual (rawIdentS "DUMMY"))) [C.Param pid []]
-- | Lookup lintype for a function -- | Lookup lintype for a function
lookupLinType :: C.FunId -> Either String C.LinType lookupLinType :: C.FunId -> Either String C.LinType
@@ -171,13 +172,13 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
let (C.ParamDef tpid _) = def let (C.ParamDef tpid _) = def
return (term, Just $ C.ParamType (C.ParamTypeId tpid)) return (term, Just $ C.ParamType (C.ParamTypeId tpid))
C.PredefValue (C.PredefId pid) -> case pid of C.PredefValue (C.PredefId pid) -> case showRawIdent pid of
"BIND" -> return (L.Bind, Nothing) "BIND" -> return (L.Bind, Nothing)
"SOFT_BIND" -> return (L.Bind, Nothing) "SOFT_BIND" -> return (L.Bind, Nothing)
"SOFT_SPACE" -> return (L.Space, Nothing) "SOFT_SPACE" -> return (L.Space, Nothing)
"CAPIT" -> return (L.Capit, Nothing) "CAPIT" -> return (L.Capit, Nothing)
"ALL_CAPIT" -> return (L.AllCapit, Nothing) "ALL_CAPIT" -> return (L.AllCapit, Nothing)
_ -> Left $ printf "Unknown predef function: %s" pid x -> Left $ printf "Unknown predef function: %s" x
C.RecordValue rrvs -> do C.RecordValue rrvs -> do
let rrvs' = sortRecordRows rrvs let rrvs' = sortRecordRows rrvs
@@ -332,7 +333,7 @@ sortRecordRows :: [C.RecordRowValue] -> [C.RecordRowValue]
sortRecordRows = L.sortBy ordLabel sortRecordRows = L.sortBy ordLabel
where where
ordLabel (C.RecordRow (C.LabelId l1) _) (C.RecordRow (C.LabelId l2) _) = ordLabel (C.RecordRow (C.LabelId l1) _) (C.RecordRow (C.LabelId l2) _) =
case (l1,l2) of case (showRawIdent l1, showRawIdent l2) of
("s",_) -> LT ("s",_) -> LT
(_,"s") -> GT (_,"s") -> GT
(s1,s2) -> compare s1 s2 (s1,s2) -> compare s1 s2
@@ -407,13 +408,13 @@ eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
eitherElemIndex x xs = m2e (printf "Cannot find: %s in %s" (show x) (show xs)) (elemIndex x xs) eitherElemIndex x xs = m2e (printf "Cannot find: %s in %s" (show x) (show xs)) (elemIndex x xs)
mdi2s :: C.ModId -> String mdi2s :: C.ModId -> String
mdi2s (C.ModId i) = i mdi2s (C.ModId i) = showRawIdent i
mdi2i :: C.ModId -> CId mdi2i :: C.ModId -> CId
mdi2i (C.ModId i) = mkCId i mdi2i (C.ModId i) = mkCId (showRawIdent i)
fi2i :: C.FunId -> CId fi2i :: C.FunId -> CId
fi2i (C.FunId i) = mkCId i fi2i (C.FunId i) = mkCId (showRawIdent i)
-- Debugging -- Debugging

3
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -11,6 +11,7 @@
module GF.Grammar.Canonical where module GF.Grammar.Canonical where
import Prelude hiding ((<>)) import Prelude hiding ((<>))
import GF.Text.Pretty import GF.Text.Pretty
import GF.Infra.Ident (RawIdent)
-- | A Complete grammar -- | A Complete grammar
data Grammar = Grammar Abstract [Concrete] deriving Show data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers -- *** Identifiers
type Id = String type Id = RawIdent
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show) data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

17
src/compiler/GF/Grammar/CanonicalJSON.hs
View File

@@ -7,6 +7,7 @@ import Control.Applicative ((<|>))
import Data.Ratio (denominator, numerator) import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical import GF.Grammar.Canonical
import Control.Monad (guard) import Control.Monad (guard)
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
encodeJSON :: FilePath -> Grammar -> IO () encodeJSON :: FilePath -> Grammar -> IO ()
@@ -204,12 +205,12 @@ instance JSON a => JSON (RecordRow a) where
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects) -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
showJSON row = showJSONs [row] showJSON row = showJSONs [row]
showJSONs rows = makeObj (map toRow rows) showJSONs rows = makeObj (map toRow rows)
where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
readJSON obj = head <$> readJSONs obj readJSON obj = head <$> readJSONs obj
readJSONs obj = mapM fromRow (assocsJSObject obj) readJSONs obj = mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (RecordRow (LabelId lbl) value) return (RecordRow (LabelId (rawIdentS lbl)) value)
instance JSON rhs => JSON (TableRow rhs) where instance JSON rhs => JSON (TableRow rhs) where
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
@@ -242,20 +243,24 @@ instance JSON VarId where
<|> VarId <$> readJSON o <|> VarId <$> readJSON o
instance JSON QualId where instance JSON QualId where
showJSON (Qual (ModId m) n) = showJSON (m++"."++n) showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
showJSON (Unqual n) = showJSON n showJSON (Unqual n) = showJSON n
readJSON o = do qualid <- readJSON o readJSON o = do qualid <- readJSON o
let (mod, id) = span (/= '.') qualid let (mod, id) = span (/= '.') qualid
return $ if null mod then Unqual id else Qual (ModId mod) id return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
instance JSON RawIdent where
showJSON i = showJSON $ showRawIdent i
readJSON o = rawIdentS <$> readJSON o
instance JSON Flags where instance JSON Flags where
-- flags are encoded directly as JSON records (i.e., objects): -- flags are encoded directly as JSON records (i.e., objects):
showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs] showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj) readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (lbl, value) return (rawIdentS lbl, value)
instance JSON FlagValue where instance JSON FlagValue where
-- flag values are encoded as basic JSON types: -- flag values are encoded as basic JSON types:

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

@@ -77,7 +77,6 @@ instance Binary RawIdent where
put = put . rawId2utf8 put = put . rawId2utf8
get = fmap rawIdentC get get = fmap rawIdentC get
-- | This function should be used with care, since the returned ByteString is -- | This function should be used with care, since the returned ByteString is
-- UTF-8-encoded. -- UTF-8-encoded.
ident2utf8 :: Ident -> UTF8.ByteString ident2utf8 :: Ident -> UTF8.ByteString
@@ -88,6 +87,7 @@ ident2utf8 i = case i of
IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j)) IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
IW -> pack "_" IW -> pack "_"
ident2raw :: Ident -> RawIdent
ident2raw = Id . ident2utf8 ident2raw = Id . ident2utf8
showIdent :: Ident -> String showIdent :: Ident -> String
@@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i
instance Pretty Ident where pp = pp . showIdent instance Pretty Ident where pp = pp . showIdent
instance Pretty RawIdent where pp = pp . showRawIdent
identS :: String -> Ident identS :: String -> Ident
identS = identC . rawIdentS identS = identC . rawIdentS
identC :: RawIdent -> Ident identC :: RawIdent -> Ident
identW :: Ident identW :: Ident
prefixIdent :: String -> Ident -> Ident prefixIdent :: String -> Ident -> Ident
prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8 prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8

5
testsuite/lpgf/README.md
View File

@@ -160,6 +160,11 @@ Max memory: 619.71 MB
- size: 2.48 MB Phrasebook.lpgf - size: 2.48 MB Phrasebook.lpgf
Max memory: 1.15 GB Max memory: 1.15 GB
**RawIdents**
- compile: 5.393466s
- size: 3.01 MB Phrasebook.lpgf
Max memory: 1.12 GB
### Repeated terms in compilation ### Repeated terms in compilation
**Param and Table** **Param and Table**