msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests 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 was cherry-picked from d0c27cdaae (lpgf branch)
This commit is contained in:
John J. Camilleri
2021-06-30 10:58:23 +02:00
parent 6efbd23c5c
commit 0a70eca6e2
5 changed files with 86 additions and 76 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
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
@@ -69,7 +69,7 @@ concrete2haskell opts
where where
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs] --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
allcats = S.fromList [c | CatDef c _<-cats] allcats = S.fromList [c | CatDef c _<-cats]
gId :: ToIdent i => i -> Ident gId :: ToIdent i => i -> Ident
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G") gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
. toIdent . toIdent
@@ -116,7 +116,7 @@ concrete2haskell opts
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs] where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
StrType -> tcon0 (identS "Str") StrType -> tcon0 (identS "Str")
TableType pt lt -> Fun (ppT pt) (ppT lt) TableType pt lt -> Fun (ppT pt) (ppT lt)
-- TupleType lts -> -- TupleType lts ->
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t) lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
@@ -126,7 +126,7 @@ concrete2haskell opts
linDefs = map eqn . sortOn fst . map linDef linDefs = map eqn . sortOn fst . map linDef
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs) where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
linDef (LinDef f xs rhs0) = linDef (LinDef f xs rhs0) =
(cat,(linfunName cat,(lhs,rhs))) (cat,(linfunName cat,(lhs,rhs)))
where where
lhs = [ConP (aId f) (map VarP abs_args)] lhs = [ConP (aId f) (map VarP abs_args)]
@@ -144,7 +144,7 @@ concrete2haskell opts
where where
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args] vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)] env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) = letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a))) (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
@@ -187,7 +187,7 @@ concrete2haskell opts
pId p@(ParamId s) = pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
table cs = table cs =
if all (null.patVars) ps if all (null.patVars) ps
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts']) then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
@@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where
-- | Record subtyping is converted into explicit coercions in Haskell -- | Record subtyping is converted into explicit coercions in Haskell
coerce env ty t = coerce env ty t =
case (ty,t) of case (ty,t) of
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts) (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) -> (TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs] TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) -> (RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) | RecordValue [RecordRow l (coerce env ft f) |
RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]] RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
(RecordType rt,VarValue x)-> (RecordType rt,VarValue x)->
case lookup x env of case lookup x env of
Just ty' | ty'/=ty -> -- better to compare to normal form of ty' Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
@@ -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

36
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(optionsPGF) import GF.Infra.Option(optionsPGF)
import PGF.Internal(Literal(..)) import PGF.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
@@ -69,10 +69,10 @@ concretes2canonical opts absname gr =
concrete2canonical gr cenv absname cnc modinfo = concrete2canonical gr cenv absname cnc modinfo =
Concrete (modId cnc) (modId absname) (convFlags gr cnc) Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs)) (neededParamTypes S.empty (params defs))
[lincat|(_,Left lincat)<-defs] [lincat | (_,Left lincat) <- defs]
[lin|(_,Right lin)<-defs] [lin | (_,Right lin) <- defs]
where where
defs = concatMap (toCanonical gr absname cenv) . defs = concatMap (toCanonical gr absname cenv) .
M.toList $ M.toList $
jments modinfo jments modinfo
@@ -188,8 +188,8 @@ 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
PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
@@ -247,7 +247,7 @@ projection r l = maybe (Projection r l) id (proj r l)
proj r l = proj r l =
case r of case r of
RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
[v] -> Just v [v] -> Just v
_ -> Nothing _ -> Nothing
_ -> Nothing _ -> Nothing
@@ -257,7 +257,7 @@ selection t v =
-- Note: impossible cases can become possible after grammar transformation -- Note: impossible cases can become possible after grammar transformation
case t of case t of
TableValue tt r -> TableValue tt r ->
case nub [rv|TableRow _ rv<-keep] of case nub [rv | TableRow _ rv <- keep] of
[rv] -> rv [rv] -> rv
_ -> Selection (TableValue tt r') v _ -> Selection (TableValue tt r') v
where where
@@ -357,16 +357,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
@@ -375,11 +379,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 =

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)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

37
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 ()
@@ -29,7 +30,7 @@ instance JSON Grammar where
-- ** Abstract Syntax -- ** Abstract Syntax
instance JSON Abstract where instance JSON Abstract where
showJSON (Abstract absid flags cats funs) showJSON (Abstract absid flags cats funs)
= makeObj [("abs", showJSON absid), = makeObj [("abs", showJSON absid),
("flags", showJSON flags), ("flags", showJSON flags),
("cats", showJSON cats), ("cats", showJSON cats),
@@ -81,7 +82,7 @@ instance JSON TypeBinding where
-- ** Concrete syntax -- ** Concrete syntax
instance JSON Concrete where instance JSON Concrete where
showJSON (Concrete cncid absid flags params lincats lins) showJSON (Concrete cncid absid flags params lincats lins)
= makeObj [("cnc", showJSON cncid), = makeObj [("cnc", showJSON cncid),
("abs", showJSON absid), ("abs", showJSON absid),
("flags", showJSON flags), ("flags", showJSON flags),
@@ -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)]
@@ -219,19 +220,19 @@ instance JSON rhs => JSON (TableRow rhs) where
-- *** Identifiers in Concrete Syntax -- *** Identifiers in Concrete Syntax
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax -- ** Used in both Abstract and Concrete Syntax
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
instance JSON VarId where instance JSON VarId where
-- the anonymous variable is the underscore: -- the anonymous variable is the underscore:
@@ -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:

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

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/11/15 11:43:33 $ -- > CVS $Date: 2005/11/15 11:43:33 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $ -- > CVS $Revision: 1.8 $
-- --
@@ -13,18 +13,18 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Infra.Ident (-- ** Identifiers module GF.Infra.Ident (-- ** Identifiers
ModuleName(..), moduleNameS, ModuleName(..), moduleNameS,
Ident, ident2utf8, showIdent, prefixIdent, Ident, ident2utf8, showIdent, prefixIdent,
-- *** Normal identifiers (returned by the parser) -- *** Normal identifiers (returned by the parser)
identS, identC, identW, identS, identC, identW,
-- *** Special identifiers for internal use -- *** Special identifiers for internal use
identV, identA, identAV, identV, identA, identAV,
argIdent, isArgIdent, getArgIndex, argIdent, isArgIdent, getArgIndex,
varStr, varX, isWildIdent, varIndex, varStr, varX, isWildIdent, varIndex,
-- *** Raw identifiers -- *** Raw identifiers
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent, RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
isPrefixOf, showRawIdent isPrefixOf, showRawIdent
) where ) where
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf) import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m
-- | the constructors labelled /INTERNAL/ are -- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser -- internal representation never returned by the parser
data Ident = data Ident =
IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard | IW -- ^ wildcard
-- --
@@ -54,7 +54,7 @@ data Ident =
| IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable | IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable
| IA {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position | IA {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position
| IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position
-- --
deriving (Eq, Ord, Show, Read) deriving (Eq, Ord, Show, Read)
-- | Identifiers are stored as UTF-8-encoded bytestrings. -- | Identifiers are stored as UTF-8-encoded bytestrings.
@@ -70,14 +70,13 @@ rawIdentS = Id . pack
rawIdentC = Id rawIdentC = Id
showRawIdent = unpack . rawId2utf8 showRawIdent = unpack . rawId2utf8
prefixRawIdent (Id x) (Id y) = Id (BS.append x y) prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
instance Binary RawIdent where 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
@@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident
identA :: RawIdent -> Int -> Ident identA :: RawIdent -> Int -> Ident
identAV:: RawIdent -> Int -> Int -> Ident identAV:: RawIdent -> Int -> Int -> Ident
(identC, identV, identA, identAV, identW) = (identC, identV, identA, identAV, identW) =
(IC, IV, IA, IAV, IW) (IC, IV, IA, IAV, IW)
-- | to mark argument variables -- | to mark argument variables