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

unlexer concat

Browse Source
This commit is contained in:
aarne
2005-02-08 15:35:58 +00:00
parent 6fe9cca0ff
commit 4fd0c636f8
9 changed files with 106 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

33
src/GF/Canon/Share.hs
View File

@@ -18,6 +18,7 @@ import AbsGFC
import Ident
import GFC
import qualified CMacros as C
import PrGrammar (prt)
import Operations
import List
import qualified Modules as M
@@ -39,15 +40,15 @@ shareModule opt (i,m) = case m of
(i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
_ -> (i,m)
shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt t) m)
shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt t) m)
shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m)
shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m)
shareInfo _ i = i
-- the function putting together optimizations
shareOptim :: OptSpec -> Term -> Term
shareOptim opt
| doOptFactor opt && doOptValues opt = values . factor 0
| doOptFactor opt = share . factor 0
shareOptim :: OptSpec -> Ident -> Term -> Term
shareOptim opt c
| doOptFactor opt && doOptValues opt = values . factor c 0
| doOptFactor opt = share . factor c 0
| doOptValues opt = values
| otherwise = share
@@ -80,22 +81,22 @@ share t = case t of
-- do even more: factor parametric branches
factor :: Int -> Term -> Term
factor i t = case t of
factor :: Ident -> Int -> Term -> Term
factor c i t = case t of
T _ [_] -> t
T _ [] -> t
T ty cs -> T ty $ factors i [Cas [p] (factor (i+1) v) | Cas ps v <- cs, p <- ps]
R lts -> R [Ass l (factor i t) | Ass l t <- lts]
P t l -> P (factor i t) l
S t a -> S (factor i t) (factor i a)
C t a -> C (factor i t) (factor i a)
FV ts -> FV (map (factor i) ts)
T ty cs -> T ty $ factors i [Cas [p] (factor c (i+1) v) | Cas ps v <- cs, p <- ps]
R lts -> R [Ass l (factor c i t) | Ass l t <- lts]
P t l -> P (factor c i t) l
S t a -> S (factor c i t) (factor c i a)
C t a -> C (factor c i t) (factor c i a)
FV ts -> FV (map (factor c i) ts)
_ -> t
where
factors i psvs = -- we know psvs has at least 2 elements
let p = pIdent i
let p = pIdent c i
vs' = map (mkFun p) psvs
in if allEqs vs'
then mkCase p vs'
@@ -107,7 +108,7 @@ factor i t = case t of
mkCase p (v:_) = [Cas [PV p] v]
pIdent i = identC ("p__" ++ show i)
pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i)
-- we need to replace subterms

27
src/GF/Compile/BackOpt.hs
View File

@@ -17,6 +17,7 @@ module BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
import Grammar
import Ident
import qualified Macros as C
import PrGrammar (prt)
import Operations
import List
import qualified Modules as M
@@ -38,16 +39,16 @@ shareModule opt (i,m) = case m of
(i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
_ -> (i,m)
shareInfo opt (c, CncCat ty (Yes t) m) = (c, CncCat ty (Yes (shareOptim opt t)) m)
shareInfo opt (c, CncFun kxs (Yes t) m) = (c, CncFun kxs (Yes (shareOptim opt t)) m)
shareInfo opt (c, ResOper ty (Yes t)) = (c, ResOper ty (Yes (shareOptim opt t)))
shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)
shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
shareInfo _ i = i
-- the function putting together optimizations
shareOptim :: OptSpec -> Term -> Term
shareOptim opt
| doOptFactor opt && doOptValues opt = values . factor 0
| doOptFactor opt = share . factor 0
shareOptim :: OptSpec -> Ident -> Term -> Term
shareOptim opt c
| doOptFactor opt && doOptValues opt = values . factor c 0
| doOptFactor opt = share . factor c 0
| doOptValues opt = values
| otherwise = share
@@ -73,17 +74,17 @@ share t = case t of
-- do even more: factor parametric branches
factor :: Int -> Term -> Term
factor i t = case t of
factor :: Ident -> Int -> Term -> Term
factor c i t = case t of
T _ [_] -> t
T _ [] -> t
T (TComp ty) cs ->
T (TTyped ty) $ factors i [(p, factor (i+1) v) | (p, v) <- cs]
_ -> C.composSafeOp (factor i) t
T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
_ -> C.composSafeOp (factor c i) t
where
factors i psvs = -- we know psvs has at least 2 elements
let p = qqIdent i
let p = qqIdent c i
vs' = map (mkFun p) psvs
in if allEqs vs'
then mkCase p vs'
@@ -97,7 +98,7 @@ factor i t = case t of
--- we hope this will be fresh and don't check... in GFC would be safe
qqIdent i = identC ("q4q__" ++ show i)
qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
-- we need to replace subterms

14
src/GF/Compile/MkResource.hs
View File

@@ -18,6 +18,7 @@ import Grammar
import Ident
import Modules
import Macros
import Lockfield
import PrGrammar
import Operations
@@ -118,19 +119,6 @@ mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs wher
Q n c | n == a || [n] == mae -> return $ Q r c ---- FIX for non-singleton exts
_ -> composOp (redirTyp always a mae) ty
lockRecType :: Ident -> Type -> Err Type
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]
unlockRecord :: Ident -> Term -> Err Term
unlockRecord c ft = do
let (xs,t) = termFormCnc ft
t' <- plusRecord t $ R [(lockLabel c, (Just (RecType []),R []))]
return $ mkAbs xs t'
lockLabel :: Ident -> Label
lockLabel c = LIdent $ "lock_" ++ prt c ----
-- no reuse for functions of HO/dep types
isHardType t = case t of

6
src/GF/Compile/ModDeps.hs
View File

@@ -9,7 +9,7 @@
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-- Check correctness of module dependencies. Incomplete.
-----------------------------------------------------------------------------
module ModDeps where
@@ -81,8 +81,8 @@ moduleDeps ms = mapM deps ms where
chDep it es ety os oty = do
ests <- mapM (lookupModuleType gr) es
testErr (all (compatMType ety) ests) "inappropriate extension module type"
osts <- mapM (lookupModuleType gr . openedModule) os
testErr (all (compatOType oty) osts) "inappropriate open module type"
---- osts <- mapM (lookupModuleType gr . openedModule) os
---- testErr (all (compatOType oty) osts) "inappropriate open module type"
let ab = case it of
IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
_ -> [] ----

24
src/GF/Grammar/AppPredefined.hs
View File

@@ -9,7 +9,7 @@
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
module AppPredefined where
@@ -18,7 +18,7 @@ import Operations
import Grammar
import Ident
import Macros
import PrGrammar (prt,prtBad)
import PrGrammar (prt,prt_,prtBad)
---- import PGrammar (pTrm)
-- predefined function type signatures and definitions. AR 12/3/2003.
@@ -42,7 +42,10 @@ typPredefined c@(IC f) = case f of
"occur" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
"plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
---- "read" -> (P : Type) -> Tok -> P
---- "show" -> (P : Type) -> P -> Tok
"show" -> return $ mkProd -- (P : PType) -> P -> Tok
([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[])
"toStr" -> return $ mkProd -- (L : Type) -> L -> Str
([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[])
"take" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"tk" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
_ -> prtBad "unknown in Predef:" c
@@ -69,8 +72,10 @@ appPredefined t = case t of
("eqInt",EInt i, EInt j) -> if i==j then predefTrue else predefFalse
("lessInt",EInt i, EInt j) -> if i<j then predefTrue else predefFalse
("plus", EInt i, EInt j) -> EInt $ i+j
("show", _, t) -> K $ prt t
("show", _, t) -> foldr C Empty $ map K $ words $ prt t
("read", _, K s) -> str2tag s --- because of K, only works for atomic tags
("toStr", _, t) -> trm2str t
_ -> t
_ -> t
_ -> t
@@ -97,3 +102,14 @@ substring s t = case (s,t) of
([],_) -> True
_ -> False
trm2str :: Term -> Term
trm2str t = case t of
R ((_,(_,s)):_) -> trm2str s
T _ ((_,s):_) -> trm2str s
TSh _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s
C _ _ -> t
K _ -> t
Empty -> t
_ -> K $ "ERROR_toStr_" ++ prt_ t --- eliminated by type checker

37
src/GF/Grammar/Lockfield.hs Normal file
View File

@@ -0,0 +1,37 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- Creating and using lock fields in reused resource grammars.
-----------------------------------------------------------------------------
module Lockfield where
import Grammar
import Ident
import Macros
import PrGrammar
import Operations
-- AR 8/2/2005 detached from compile/MkResource
lockRecType :: Ident -> Type -> Err Type
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]
unlockRecord :: Ident -> Term -> Err Term
unlockRecord c ft = do
let (xs,t) = termFormCnc ft
t' <- plusRecord t $ R [(lockLabel c, (Just (RecType []),R []))]
return $ mkAbs xs t'
lockLabel :: Ident -> Label
lockLabel c = LIdent $ "lock_" ++ prt c ----

11
src/GF/Grammar/Lookup.hs
View File

@@ -17,6 +17,7 @@ module Lookup where
import Operations
import Abstract
import Modules
import Lockfield
import List (nub)
import Monad
@@ -34,6 +35,11 @@ lookupResDef gr = look True where
ResOper _ (Yes t) -> return $ qualifAnnot m t
ResOper _ Nope -> return (Q m c) ---- if isTop then lookExt m c
---- else prtBad "cannot find in exts" c
CncCat (Yes ty) _ _ -> lockRecType c $ ty
CncCat _ _ _ -> lockRecType c $ defLinType
CncFun _ (Yes tr) _ -> unlockRecord c tr
AnyInd _ n -> look False n c
ResParam _ -> return $ QC m c
ResValue _ -> return $ QC m c
@@ -51,6 +57,11 @@ lookupResType gr m c = do
case info of
ResOper (Yes t) _ -> return $ qualifAnnot m t
ResOper (May n) _ -> lookupResType gr n c
-- used in reused concrete
CncCat _ _ _ -> return typeType
CncFun (Just (_,(cont,val))) _ _ -> return $ mkProd (cont, val, [])
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
ResValue (Yes t) -> return $ qualifAnnotPar m t

2
src/GF/UseGrammar/Custom.hs
View File

@@ -75,6 +75,7 @@ import MoreCustom -- either small/ or big/. The one in Small is empty.
import UseIO
import Monad
import Char
-- character codings
import Unicode
@@ -365,6 +366,7 @@ customUntokenizer =
(strCI "unwords", const $ id) -- DEFAULT
,(strCI "text", const $ formatAsText)
,(strCI "code", const $ formatAsCode)
,(strCI "concat", const $ filter (not . isSpace))
,(strCI "textlit", const $ formatAsTextLit)
,(strCI "codelit", const $ formatAsCodeLit)
,(strCI "concat", const $ concatRemSpace)

2
src/GF/UseGrammar/Randomized.hs
View File

@@ -45,7 +45,7 @@ mkTreeFromInts ints gr catfun = do
return $ loc2tree state
mkStateFromInts :: [Int] -> CGrammar -> Action
mkStateFromInts ints gr = mkRandomState ints where
mkStateFromInts ints gr z = mkRandomState ints z >>= reCheckState gr where
mkRandomState [] state = do
testErr (isCompleteState state) "not completed"
return state