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

simple refactoring in PGF.Macros and related

Browse Source
This commit is contained in:
krasimir
2010-12-06 14:19:51 +00:00
parent 0f444d8893
commit b6446ec36d
5 changed files with 17 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Command/Commands.hs
View File

@@ -985,7 +985,7 @@ allCommands env@(pgf, mos) = Map.fromList [
Fun cid [] -> t Fun cid [] -> t
Fun cid ts -> Fun (mk cid) (map t2m ts) Fun cid ts -> Fun (mk cid) (map t2m ts)
_ -> t _ -> t
mk = mkCId . ("mk" ++) . showCId . lookValCat pgf mk = mkCId . ("mk" ++) . showCId . lookValCat (abstract pgf)
unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ---- unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----

2
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -107,7 +107,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
profilesToTerm :: [Profile] -> CFTerm profilesToTerm :: [Profile] -> CFTerm
profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps) profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)
where (argTypes,_) = catSkeleton $ lookType pgf f where (argTypes,_) = catSkeleton $ lookType (abstract pgf) f
profileToTerm :: CId -> Profile -> CFTerm profileToTerm :: CId -> Profile -> CFTerm
profileToTerm t [] = CFMeta t profileToTerm t [] = CFMeta t

2
src/compiler/GF/Speech/VoiceXML.hs
View File

@@ -39,7 +39,7 @@ grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
type Skeleton = [(CId, [(CId, [CId])])] type Skeleton = [(CId, [(CId, [CId])])]
pgfSkeleton :: PGF -> Skeleton pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | (_,f) <- fs]) pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs])
| (c,(_,fs)) <- Map.toList (cats (abstract pgf))] | (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
-- --

24
src/runtime/haskell/PGF/Macros.hs
View File

@@ -18,24 +18,24 @@ import Text.PrettyPrint
mapConcretes :: (Concr -> Concr) -> PGF -> PGF mapConcretes :: (Concr -> Concr) -> PGF -> PGF
mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) } mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
lookType :: PGF -> CId -> Type lookType :: Abstr -> CId -> Type
lookType pgf f = lookType abs f =
case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of case lookMap (error $ "lookType " ++ show f) f (funs abs) of
(ty,_,_,_) -> ty (ty,_,_,_) -> ty
lookDef :: PGF -> CId -> Maybe [Equation] lookDef :: Abstr -> CId -> Maybe [Equation]
lookDef pgf f = lookDef abs f =
case lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) of case lookMap (error $ "lookDef " ++ show f) f (funs abs) of
(_,a,eqs,_) -> eqs (_,a,eqs,_) -> eqs
isData :: PGF -> CId -> Bool isData :: Abstr -> CId -> Bool
isData pgf f = isData abs f =
case Map.lookup f (funs (abstract pgf)) of case Map.lookup f (funs abs) of
Just (_,_,Nothing,_) -> True -- the encoding of data constrs Just (_,_,Nothing,_) -> True -- the encoding of data constrs
_ -> False _ -> False
lookValCat :: PGF -> CId -> CId lookValCat :: Abstr -> CId -> CId
lookValCat pgf = valCat . lookType pgf lookValCat abs = valCat . lookType abs
lookStartCat :: PGF -> CId lookStartCat :: PGF -> CId
lookStartCat pgf = mkCId $ lookStartCat pgf = mkCId $
@@ -119,7 +119,7 @@ showPrintName :: PGF -> Language -> CId -> String
showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
-- lookup with default value -- lookup with default value
lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a lookMap :: Ord i => a -> i -> Map.Map i a -> a
lookMap d c m = Map.findWithDefault d c m lookMap d c m = Map.findWithDefault d c m
--- from Operations --- from Operations

4
src/runtime/haskell/PGF/VisualizeTree.hs
View File

@@ -65,7 +65,7 @@ graphvizAbstractTree pgf (funs,cats) = render . tree2graph
getApp e es = (e,es) getApp e es = (e,es)
getLbl scope (EFun f) = let fun = if funs then ppCId f else empty getLbl scope (EFun f) = let fun = if funs then ppCId f else empty
cat = if cats then ppCId (lookValCat pgf f) else empty cat = if cats then ppCId (lookValCat (abstract pgf) f) else empty
sep = if funs && cats then colon else empty sep = if funs && cats then colon else empty
in fun <+> sep <+> cat in fun <+> sep <+> cat
getLbl scope (ELit l) = text (escapeStr (render (ppLit l))) getLbl scope (ELit l) = text (escapeStr (render (ppLit l)))
@@ -503,7 +503,7 @@ graphvizDependencyTree format debug mlab ms pgf lang tr = case format of
wnodes = [[show i, maltws ws, showCId fun, pos, pos, morph, show dom, lab, unspec, unspec] | wnodes = [[show i, maltws ws, showCId fun, pos, pos, morph, show dom, lab, unspec, unspec] |
(i, ((fun,p),ws)) <- tail nodeWords, (i, ((fun,p),ws)) <- tail nodeWords,
let pos = showCId $ lookValCat pgf fun, let pos = showCId $ lookValCat (abstract pgf) fun,
let morph = unspec, let morph = unspec,
let (dom,lab) = lookDomLab p let (dom,lab) = lookDomLab p
] ]