msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Founding the newly structured GF2.0 cvs archive.

Browse Source
This commit is contained in:
aarne
2003-09-22 13:16:55 +00:00
commit b1402e8bd6
162 changed files with 25569 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

160
src/GF/Canon/AbsGFC.hs Normal file
View File

@@ -0,0 +1,160 @@
module AbsGFC where
import Ident --H
-- Haskell module generated by the BNF converter, except --H
-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
data Canon =
Gr [Module]
deriving (Eq,Ord,Show)
data Module =
Mod ModType Extend Open [Flag] [Def]
deriving (Eq,Ord,Show)
data ModType =
MTAbs Ident
| MTCnc Ident Ident
| MTRes Ident
deriving (Eq,Ord,Show)
data Extend =
Ext Ident
| NoExt
deriving (Eq,Ord,Show)
data Open =
NoOpens
| Opens [Ident]
deriving (Eq,Ord,Show)
data Flag =
Flg Ident Ident
deriving (Eq,Ord,Show)
data Def =
AbsDCat Ident [Decl] [CIdent]
| AbsDFun Ident Exp Exp
| ResDPar Ident [ParDef]
| ResDOper Ident CType Term
| CncDCat Ident CType Term Term
| CncDFun Ident CIdent [ArgVar] Term Term
| AnyDInd Ident Status Ident
deriving (Eq,Ord,Show)
data ParDef =
ParD Ident [CType]
deriving (Eq,Ord,Show)
data Status =
Canon
| NonCan
deriving (Eq,Ord,Show)
data CIdent =
CIQ Ident Ident
deriving (Eq,Ord,Show)
data Exp =
EApp Exp Exp
| EProd Ident Exp Exp
| EAbs Ident Exp
| EAtom Atom
| EEq [Equation]
deriving (Eq,Ord,Show)
data Sort =
SType
deriving (Eq,Ord,Show)
data Equation =
Equ [APatt] Exp
deriving (Eq,Ord,Show)
data APatt =
APC CIdent [APatt]
| APV Ident
| APS String
| API Integer
| APW
deriving (Eq,Ord,Show)
data Atom =
AC CIdent
| AD CIdent
| AV Ident
| AM Integer
| AS String
| AI Integer
| AT Sort
deriving (Eq,Ord,Show)
data Decl =
Decl Ident Exp
deriving (Eq,Ord,Show)
data CType =
RecType [Labelling]
| Table CType CType
| Cn CIdent
| TStr
deriving (Eq,Ord,Show)
data Labelling =
Lbg Label CType
deriving (Eq,Ord,Show)
data Term =
Arg ArgVar
| I CIdent
| Con CIdent [Term]
| LI Ident
| R [Assign]
| P Term Label
| T CType [Case]
| S Term Term
| C Term Term
| FV [Term]
| K Tokn
| E
deriving (Eq,Ord,Show)
data Tokn =
KS String
| KP [String] [Variant]
deriving (Eq,Ord,Show)
data Assign =
Ass Label Term
deriving (Eq,Ord,Show)
data Case =
Cas [Patt] Term
deriving (Eq,Ord,Show)
data Variant =
Var [String] [String]
deriving (Eq,Ord,Show)
data Label =
L Ident
| LV Integer
deriving (Eq,Ord,Show)
data ArgVar =
A Ident Integer
| AB Ident Integer Integer
deriving (Eq,Ord,Show)
data Patt =
PC CIdent [Patt]
| PV Ident
| PW
| PR [PattAssign]
deriving (Eq,Ord,Show)
data PattAssign =
PAss Label Patt
deriving (Eq,Ord,Show)

234
src/GF/Canon/CMacros.hs Normal file
View File

@@ -0,0 +1,234 @@
module CMacros where
import AbsGFC
import GFC
import qualified Ident as A ---- no need to qualif? 21/9
import PrGrammar
import Str
import Operations
import Char
import Monad
-- macros for concrete syntax in GFC that do not need lookup in a grammar
markFocus :: Term -> Term
markFocus = markSubterm "[*" "*]"
markSubterm :: String -> String -> Term -> Term
markSubterm beg end t = case t of
R rs -> R $ map markField rs
T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
_ -> foldr1 C [tK beg, t, tK end] -- t : Str guaranteed?
where
mark = markSubterm beg end
markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
isLinLabel (L (A.IC s)) = case s of ----
's':cs -> all isDigit cs
_ -> False
tK :: String -> Term
tK = K . KS
term2patt :: Term -> Err Patt
term2patt trm = case trm of
Con c aa -> do
aa' <- mapM term2patt aa
return (PC c aa')
R r -> do
let (ll,aa) = unzip [(l,a) | Ass l a <- r]
aa' <- mapM term2patt aa
return (PR (map (uncurry PAss) (zip ll aa')))
LI x -> return $ PV x
_ -> prtBad "no pattern corresponds to term" trm
patt2term :: Patt -> Term
patt2term p = case p of
PC x ps -> Con x (map patt2term ps)
PV x -> LI x
PW -> anyTerm ----
PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ]
anyTerm :: Term
anyTerm = LI (A.identC "_") --- should not happen
matchPatt cs0 trm = term2patt trm >>= match cs0 where
match cs t =
case cs of
Cas ps b :_ | elem t ps -> return b
_:cs' -> match cs' t
[] -> Bad $ "pattern not found for" +++ prt t
+++ "among" ++++ unlines (map prt cs0) ---- debug
defLinType :: CType
defLinType = RecType [Lbg (L (A.identC "s")) TStr]
defLindef :: Term
defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))]
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case t of
K (KS s) -> return [str s]
K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]]
C s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [plusStr x y | x <- s', y <- t']
FV ts -> liftM concat $ mapM strsFromTerm ts
E -> return [str []]
_ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug
---- _ -> prtBad "cannot get Str from term " t
-- recursively collect all branches in a table
allInTable :: Term -> [Term]
allInTable t = case t of
T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ?
_ -> [t]
-- to gather s-fields; assumes term in normal form, preserves label
allLinFields :: Term -> Err [[(Label,Term)]]
allLinFields trm = case trm of
---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad
FV ts -> do
lts <- mapM allLinFields ts
return $ concat lts
_ -> prtBad "fields can only be sought in a record not in" trm
---- deprecated
isLinLabel l = case l of
L (A.IC ('s':cs)) | all isDigit cs -> True
_ -> False
-- to gather ultimate cases in a table; preserves pattern list
allCaseValues :: Term -> [([Patt],Term)]
allCaseValues trm = case trm of
T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0]
_ -> [([],trm)]
-- to gather all linearizations; assumes normal form, preserves label and args
allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
allLinValues trm = do
lts <- allLinFields trm
mapM (mapPairsM (return . allCaseValues)) lts
redirectIdent n f@(CIQ _ c) = CIQ n c
{- ---- to be removed 21/9
-- to analyse types and terms into eta normal form
typeForm :: Exp -> Err (Context, Exp, [Exp])
typeForm e = do
(cont,val) <- getContext e
(cat,args) <- getArgs val
return (cont,cat,args)
getContext :: Exp -> Err (Context, Exp)
getContext e = case e of
EProd x a b -> do
(g,b') <- getContext b
return ((x,a):g,b')
_ -> return ([],e)
valAtom :: Exp -> Err Atom
valAtom e = do
(_,val,_) <- typeForm e
case val of
EAtom a -> return a
_ -> prtBad "atom expected instead of" val
valCat :: Exp -> Err CIdent
valCat e = do
a <- valAtom e
case a of
AC c -> return c
_ -> prtBad "cat expected instead of" a
termForm :: Exp -> Err ([A.Ident], Exp, [Exp])
termForm e = do
(cont,val) <- getBinds e
(cat,args) <- getArgs val
return (cont,cat,args)
getBinds :: Exp -> Err ([A.Ident], Exp)
getBinds e = case e of
EAbs x b -> do
(g,b') <- getBinds b
return (x:g,b')
_ -> return ([],e)
getArgs :: Exp -> Err (Exp,[Exp])
getArgs = get [] where
get xs e = case e of
EApp f a -> get (a:xs) f
_ -> return (e, reverse xs)
-- the inverses of these
mkProd :: Context -> Exp -> Exp
mkProd c e = foldr (uncurry EProd) e c
mkApp :: Exp -> [Exp] -> Exp
mkApp = foldl EApp
mkAppAtom :: Atom -> [Exp] -> Exp
mkAppAtom a = mkApp (EAtom a)
mkAppCons :: CIdent -> [Exp] -> Exp
mkAppCons c = mkAppAtom $ AC c
mkType :: Context -> Exp -> [Exp] -> Exp
mkType c e xs = mkProd c $ mkApp e xs
mkAbs :: Context -> Exp -> Exp
mkAbs c e = foldr EAbs e $ map fst c
mkTerm :: Context -> Exp -> [Exp] -> Exp
mkTerm c e xs = mkAbs c $ mkApp e xs
mkAbsR :: [A.Ident] -> Exp -> Exp
mkAbsR c e = foldr EAbs e c
mkTermR :: [A.Ident] -> Exp -> [Exp] -> Exp
mkTermR c e xs = mkAbsR c $ mkApp e xs
-- this is used to create heuristic menus
eqCatId :: Cat -> Atom -> Bool
eqCatId (CIQ _ c) b = case b of
AC (CIQ _ d) -> c == d
AD (CIQ _ d) -> c == d
_ -> False
-- a very weak notion of "compatible value category"
compatCat :: Cat -> Type -> Bool
compatCat c t = case t of
EAtom b -> eqCatId c b
EApp f _ -> compatCat c f
_ -> False
-- this is the way an atomic category looks as a type
cat2type :: Cat -> Type
cat2type = EAtom . AC
compatType :: Type -> Type -> Bool
compatType t = case t of
EAtom (AC c) -> compatCat c
_ -> (t ==)
type Fun = CIdent
type Cat = CIdent
type Type = Exp
mkFun, mkCat :: String -> String -> Fun
mkFun m f = CIQ (A.identC m) (A.identC f)
mkCat = mkFun
mkFunC, mkCatC :: String -> Fun
mkFunC s = let (m,f) = span (/= '.') s in mkFun m (drop 1 f)
mkCatC = mkFunC
-}

167
src/GF/Canon/CanonToGrammar.hs Normal file
View File

@@ -0,0 +1,167 @@
module CanonToGrammar where
import AbsGFC
import GFC
import MkGFC
---import CMacros
import qualified Modules as M
import qualified Option as O
import qualified Grammar as G
import qualified Macros as F
import Ident
import Operations
import Monad
-- a decompiler. AR 12/6/2003
canon2sourceModule :: CanonModule -> Err G.SourceModule
canon2sourceModule (i,mi) = do
i' <- redIdent i
info' <- case mi of
M.ModMod m -> do
(e,os) <- redExtOpen m
flags <- mapM redFlag $ M.flags m
(abstr,mt) <- case M.mtype m of
M.MTConcrete a -> do
a' <- redIdent a
return (a', M.MTConcrete a')
M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
M.MTResource -> return (i',M.MTResource) --- c' not needed
defs <- mapMTree redInfo $ M.jments m
return $ M.ModMod $ M.Module mt flags e os defs
_ -> Bad $ "cannot decompile module type"
return (i',info')
where
redExtOpen m = do
e' <- case M.extends m of
Just e -> liftM Just $ redIdent e
_ -> return Nothing
os' <- mapM (\ (M.OSimple i) -> liftM (\i -> M.OQualif i i) (redIdent i)) $
M.opens m
return (e',os')
redInfo :: (Ident,Info) -> Err (Ident,G.Info)
redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
c' <- redIdent c
info' <- case info of
AbsCat cont fs -> do
return $ G.AbsCat (Yes cont) (Yes fs)
AbsFun typ df -> do
return $ G.AbsFun (Yes typ) (Yes df)
ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par
CncCat pty ptr ppr -> do
ty' <- redCType pty
trm' <- redCTerm ptr
ppr' <- redCTerm ppr
return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr')
CncFun (CIQ abstr cat) xx body ppr -> do
xx' <- mapM redArgVar xx
body' <- redCTerm body
ppr' <- redCTerm ppr
return $ G.CncFun Nothing (Yes (F.mkAbs xx' body')) (Yes ppr')
AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
return (c',info')
redQIdent :: CIdent -> Err G.QIdent
redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c)
redIdent :: Ident -> Err Ident
redIdent = return
redFlag :: Flag -> Err O.Option
redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x])
redDecl :: Decl -> Err G.Decl
redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a)
redType :: Exp -> Err G.Type
redType = redTerm
redTerm :: Exp -> Err G.Term
redTerm t = return $ trExp t
-- resource
redParam (ParD c cont) = do
c' <- redIdent c
cont' <- mapM redCType cont
return $ (c', [(IW,t) | t <- cont'])
-- concrete syntax
redCType :: CType -> Err G.Type
redCType t = case t of
RecType lbs -> do
let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs]
ls' = map redLabel ls
ts' <- mapM redCType ts
return $ G.RecType $ zip ls' ts'
Table p v -> liftM2 G.Table (redCType p) (redCType v)
Cn mc -> liftM (uncurry G.QC) $ redQIdent mc
TStr -> return $ F.typeStr
redCTerm :: Term -> Err G.Term
redCTerm x = case x of
Arg argvar -> liftM G.Vr $ redArgVar argvar
I cident -> liftM (uncurry G.Q) $ redQIdent cident
Con cident terms -> liftM2 F.mkApp
(liftM (uncurry G.QC) $ redQIdent cident)
(mapM redCTerm terms)
LI id -> liftM G.Vr $ redIdent id
R assigns -> do
let (ls,ts) = unzip [(l,t) | Ass l t <- assigns]
let ls' = map redLabel ls
ts' <- mapM redCTerm ts
return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts']
P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label)
T ctype cases -> do
ctype' <- redCType ctype
let (ps,ts) = unzip [(p,t) | Cas ps t <- cases, p <- ps] --- destroys sharing
ps' <- mapM redPatt ps
ts' <- mapM redCTerm ts --- duplicates work for shared rhss
let tinfo = case ps' of
[G.PV _] -> G.TTyped ctype'
_ -> G.TComp ctype'
return $ G.T tinfo $ zip ps' ts'
S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term)
C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term)
FV terms -> liftM G.FV $ mapM redCTerm terms
K (KS str) -> return $ G.K str
E -> return $ G.Empty
K (KP d vs) -> return $
G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
where
tList ss = case ss of --- this should be in Macros
[] -> G.Empty
_ -> foldr1 G.C $ map G.K ss
failure x = Bad $ "not yet" +++ show x ----
redArgVar :: ArgVar -> Err Ident
redArgVar x = case x of
A x i -> return $ IA (prIdent x, fromInteger i)
AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i)
redLabel :: Label -> G.Label
redLabel (L x) = G.LIdent $ prIdent x
redLabel (LV i) = G.LVar $ fromInteger i
redPatt :: Patt -> Err G.Patt
redPatt p = case p of
PV x -> liftM G.PV $ redIdent x
PC mc ps -> do
(m,c) <- redQIdent mc
liftM (G.PP m c) (mapM redPatt ps)
PR rs -> do
let (ls,ts) = unzip [(l,t) | PAss l t <- rs]
ls' = map redLabel ls
ts <- mapM redPatt ts
return $ G.PR $ zip ls' ts
_ -> Bad $ "cannot recompile pattern" +++ show p

48
src/GF/Canon/GFC.hs Normal file
View File

@@ -0,0 +1,48 @@
module GFC where
import AbsGFC
import PrintGFC
import qualified Abstract as A
import Ident
import Option
import Zipper
import Operations
import qualified Modules as M
import Char
-- canonical GF. AR 10/9/2002 -- 9/5/2003 -- 21/9
type Context = [(Ident,Exp)]
type CanonGrammar = M.MGrammar Ident Flag Info
type CanonModInfo = M.ModInfo Ident Flag Info
type CanonModule = (Ident, CanonModInfo)
type CanonAbs = M.Module Ident Option Info
data Info =
AbsCat A.Context [A.Fun]
| AbsFun A.Type A.Term
| ResPar [ParDef]
| ResOper CType Term -- global constant
| CncCat CType Term Printname
| CncFun CIdent [ArgVar] Term Printname
| AnyInd Bool Ident
deriving (Show)
type Printname = Term
-- some printing ----
{-
prCanonModInfo :: (Ident,CanonModInfo) -> String
prCanonModInfo = printTree . info2mod
prGrammar :: CanonGrammar -> String
prGrammar = printTree . grammar2canon
-}

22
src/GF/Canon/GetGFC.hs Normal file
View File

@@ -0,0 +1,22 @@
module GetGFC where
import Operations
import ParGFC
import GFC
import MkGFC
import Modules
import GetGrammar (err2err) ---
import UseIO
getCanonModule :: FilePath -> IOE CanonModule
getCanonModule file = do
gr <- getCanonGrammar file
case modules gr of
[m] -> return m
_ -> ioeErr $ Bad "expected exactly one module in a file"
getCanonGrammar :: FilePath -> IOE CanonGrammar
getCanonGrammar file = do
s <- ioeIO $ readFileIf file
c <- ioeErr $ err2err $ pCanon $ myLexer s
return $ canon2grammar c

105
src/GF/Canon/LexGFC.hs Normal file
View File

@@ -0,0 +1,105 @@
module LexGFC where
import Alex
import ErrM
pTSpec p = PT p . TS
ident p = PT p . eitherResIdent TV
string p = PT p . TL . unescapeInitTail
int p = PT p . TI
data Tok =
TS String -- reserved words
| TL String -- string literals
| TI String -- integer literals
| TV String -- identifiers
| TD String -- double precision float literals
| TC String -- character literals
deriving (Eq,Show)
data Token =
PT Posn Tok
| Err Posn
deriving Show
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
prToken t = case t of
PT _ (TS s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
_ -> show t
tokens:: String -> [Token]
tokens inp = scan tokens_scan inp
tokens_scan:: Scan Token
tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
where
stop_act p "" = []
stop_act p inp = [Err p]
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "lin" (B "concrete" (B "abstract" (B "Type" (B "Str" N N) N) (B "cat" N N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" N N))) (B "param" (B "open" (B "of" (B "lincat" N N) N) (B "oper" N N)) (B "table" (B "resource" (B "pre" N N) N) (B "variants" N N)))
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
tokens_acts = [("ident",ident),("int",int),("pTSpec",pTSpec),("string",string)]
tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))]
tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0]
lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1),('!',6),('"',8),('$',6),('(',6),(')',6),('*',2),('+',5),(',',6),('-',3),('.',6),('/',6),('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11),(':',6),(';',6),('<',6),('=',4),('>',6),('?',6),('@',6),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('[',6),('\\',6),(']',6),('_',6),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('{',6),('|',6),('}',6),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)]))
lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__1_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1)]))
lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__2_0 = (False,[],-1,(('*','*'),[('*',6)]))
lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__3_0 = (False,[],-1,(('>','>'),[('>',6)]))
lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__4_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',6)]))
lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__5_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',6)]))
lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__6_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[]))
lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__7_0 = (True,[(2,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',7),('0',7),('1',7),('2',7),('3',7),('4',7),('5',7),('6',7),('7',7),('8',7),('9',7),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('_',7),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)]))
lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__8_0 = (False,[],8,(('\n','\\'),[('\n',-1),('"',10),('\\',9)]))
lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__9_0 = (False,[],-1,(('"','t'),[('"',8),('\'',8),('\\',8),('n',8),('t',8)]))
lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__10_0 = (True,[(3,"string",[],Nothing,Nothing)],-1,(('0','0'),[]))
lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__11_0 = (True,[(4,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11)]))

141
src/GF/Canon/Look.hs Normal file
View File

@@ -0,0 +1,141 @@
module Look where
import AbsGFC
import GFC
import PrGrammar
import CMacros
----import Values
import MMacros
import qualified Modules as M
import Operations
import Monad
import List
-- lookup in GFC. AR 2003
-- linearization lookup
lookupCncInfo :: CanonGrammar -> CIdent -> Err Info
lookupCncInfo gr f@(CIQ m c) = do
mt <- M.lookupModule gr m
case mt of
M.ModMod a -> errIn ("module" +++ prt m) $
lookupTree prt c $ M.jments a
_ -> prtBad "not concrete module" m
lookupLin :: CanonGrammar -> CIdent -> Err Term
lookupLin gr f = do
info <- lookupCncInfo gr f
case info of
CncFun _ _ t _ -> return t
CncCat _ t _ -> return t
AnyInd _ n -> lookupLin gr $ redirectIdent n f
lookupResInfo :: CanonGrammar -> CIdent -> Err Info
lookupResInfo gr f@(CIQ m c) = do
mt <- M.lookupModule gr m
case mt of
M.ModMod a -> lookupTree prt c $ M.jments a
_ -> prtBad "not resource module" m
lookupGlobal :: CanonGrammar -> CIdent -> Err Term
lookupGlobal gr f = do
info <- lookupResInfo gr f
case info of
ResOper _ t -> return t
AnyInd _ n -> lookupGlobal gr $ redirectIdent n f
_ -> prtBad "cannot find global" f
lookupParamValues :: CanonGrammar -> CIdent -> Err [Term]
lookupParamValues gr pt@(CIQ m _) = do
info <- lookupResInfo gr pt
case info of
ResPar ps -> liftM concat $ mapM mkPar ps
AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt
_ -> prtBad "cannot find parameter type" pt
where
mkPar (ParD f co) = do
vs <- liftM combinations $ mapM (allParamValues gr) co
return $ map (Con (CIQ m f)) vs
-- this is needed since param type can also be a record type
allParamValues :: CanonGrammar -> CType -> Err [Term]
allParamValues cnc ptyp = case ptyp of
Cn pc -> lookupParamValues cnc pc
RecType r -> do
let (ls,tys) = unzip [(l,t) | Lbg l t <- r]
tss <- mapM allPV tys
return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss]
_ -> prtBad "cannot possibly find parameter values for" ptyp
where
allPV = allParamValues cnc
-- runtime computation on GFC objects
ccompute :: CanonGrammar -> [Term] -> Term -> Err Term
ccompute cnc = comp []
where
comp g xs t = case t of
Arg (A _ i) -> errIn ("argument list") $ xs !? fromInteger i
Arg (AB _ _ i) -> errIn ("argument list for binding") $ xs !? fromInteger i
I c -> look c
LI c -> lookVar c g
-- short-cut computation of selections: compute the table only if needed
S u v -> do
u' <- compt u
case u' of
T _ [Cas [PW] b] -> compt b
T _ [Cas [PV x] b] -> do
v' <- compt v
comp ((x,v') : g) xs b
T _ cs -> do
v' <- compt v
if noVar v'
then matchPatt cs v' >>= compt
else return $ S u' v'
_ -> liftM (S u') $ compt v
P u l -> do
u' <- compt u
case u' of
R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u'))
return $
lookup l [ (x,y) | Ass x y <- rs]
_ -> return $ P u' l
FV ts -> liftM FV (mapM compt ts)
C E b -> compt b
C a E -> compt a
C a b -> do
a' <- compt a
b' <- compt b
return $ case (a',b') of
(E,_) -> b'
(_,E) -> a'
_ -> C a' b'
R rs -> liftM (R . map (uncurry Ass)) $
mapPairsM compt [(l,r) | Ass l r <- rs]
-- only expand the table when the table is really needed: use expandLin
T ty rs -> liftM (T ty . map (uncurry Cas)) $
mapPairsM compt [(l,r) | Cas l r <- rs]
Con c xs -> liftM (Con c) $ mapM compt xs
_ -> return t
where
compt = comp g xs
look c = lookupGlobal cnc c
lookVar c co = case lookup c co of
Just t -> return t
_ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c ---
noVar v = case v of
LI _ -> False
R rs -> all noVar [t | Ass _ t <- rs]
_ -> True --- other cases?

121
src/GF/Canon/MkGFC.hs Normal file
View File

@@ -0,0 +1,121 @@
module MkGFC where
import GFC
import AbsGFC
import qualified Abstract as A
import PrGrammar
import Ident
import Operations
import qualified Modules as M
prCanonModInfo :: CanonModule -> String
prCanonModInfo = prt . info2mod
canon2grammar :: Canon -> CanonGrammar
canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where
mod2info m = case m of
Mod mt e os flags defs ->
let defs' = buildTree $ map def2info defs
(a,mt') = case mt of
MTAbs a -> (a,M.MTAbstract)
MTRes a -> (a,M.MTResource)
MTCnc a x -> (a,M.MTConcrete x)
in (a,M.ModMod (M.Module mt' flags (ee e) (oo os) defs'))
ee (Ext m) = Just m
ee _ = Nothing
oo (Opens ms) = map M.OSimple ms
oo _ = []
grammar2canon :: CanonGrammar -> Canon
grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules
info2mod m = case m of
(a, M.ModMod (M.Module mt flags me os defs)) ->
let defs' = map info2def $ tree2list defs
mt' = case mt of
M.MTAbstract -> MTAbs a
M.MTResource -> MTRes a
M.MTConcrete x -> MTCnc a x
in
Mod mt' (gfcE me) (gfcO os) flags defs'
where
gfcE = maybe NoExt Ext
gfcO os = if null os then NoOpens else Opens [m | M.OSimple m <- os]
-- these translations are meant to be trivial
defs2infos = sorted2tree . map def2info
def2info d = case d of
AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs))
AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df))
ResDPar c df -> (c,ResPar df)
ResDOper c ty df -> (c,ResOper ty df)
CncDCat c ty df pr -> (c, CncCat ty df pr)
CncDFun f c xs li pr -> (f, CncFun c xs li pr)
AnyDInd c b m -> (c, AnyInd (b == Canon) m)
-- from file to internal
trCont cont = [(x,trExp t) | Decl x t <- cont]
trFs = map trQIdent
trExp t = case t of
EProd x a b -> A.Prod x (trExp a) (trExp b)
EAbs x b -> A.Abs x (trExp b)
EApp f a -> A.App (trExp f) (trExp a)
EEq _ -> A.Eqs [] ---- eqs
_ -> trAt t
where
trAt (EAtom t) = case t of
AC c -> (uncurry A.Q) $ trQIdent c
AD c -> (uncurry A.QC) $ trQIdent c
AV v -> A.Vr v
AM i -> A.Meta $ A.MetaSymb $ fromInteger i
AT s -> A.Sort $ prt s
AS s -> A.K s
AI i -> A.EInt $ fromInteger i
trQIdent (CIQ m c) = (m,c)
-- from internal to file
infos2defs = map info2def . tree2list
info2def d = case d of
(c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs)
(c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df)
(c,ResPar df) -> ResDPar c df
(c,ResOper ty df) -> ResDOper c ty df
(c,CncCat ty df pr) -> CncDCat c ty df pr
(f,CncFun c xs li pr) -> CncDFun f c xs li pr
(c,AnyInd b m) -> AnyDInd c (if b then Canon else NonCan) m
rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont]
rtFs = map rtQIdent
rtExp t = case t of
A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b)
A.Abs x b -> EAbs (rtIdent x) (rtExp b)
A.App f a -> EApp (rtExp f) (rtExp a)
A.Eqs _ -> EEq [] ---- eqs
_ -> EAtom $ rtAt t
where
rtAt t = case t of
A.Q m c -> AC $ rtQIdent (m,c)
A.QC m c -> AD $ rtQIdent (m,c)
A.Vr v -> AV v
A.Meta i -> AM $ toInteger $ A.metaSymbInt i
A.Sort "Type" -> AT SType
A.K s -> AS s
A.EInt i -> AI $ toInteger i
_ -> error $ "MkGFC.rt not defined for" +++ show t
rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c)
rtIdent x
| isWildIdent x = identC "h_" --- needed in declarations
| otherwise = identC $ prt x ---

36
src/GF/Canon/PrExp.hs Normal file
View File

@@ -0,0 +1,36 @@
module PrExp where
import AbsGFC
import GFC
import Operations
-- some printing
-- print trees without qualifications
prExp :: Exp -> String
prExp e = case e of
EApp f a -> pr1 f +++ pr2 a
EAbsR x b -> "\\" ++ prtt x +++ "->" +++ prExp b
EAbs x _ b -> prExp $ EAbsR x b
EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
EAtomR a -> prAtom a
EAtom a _ -> prAtom a
_ -> prtt e
where
pr1 e = case e of
EAbsR _ _ -> prParenth $ prExp e
EAbs _ _ _ -> prParenth $ prExp e
EProd _ _ _ -> prParenth $ prExp e
_ -> prExp e
pr2 e = case e of
EApp _ _ -> prParenth $ prExp e
_ -> pr1 e
prAtom a = case a of
AC c -> prCIdent c
AD c -> prCIdent c
_ -> prtt a
prCIdent (CIQ _ c) = prtt c

319
src/GF/Canon/PrintGFC.hs Normal file
View File

@@ -0,0 +1,319 @@
module PrintGFC where
-- pretty-printer generated by the BNF converter, except handhacked spacing --H
import Ident --H
import AbsGFC
import Char
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend 0 where
rend i ss = case ss of
"NEW" :ts -> realnew $ rend i ts --H
"<" :ts -> cons "<" $ rend i ts --H
"$" :ts -> cons "$" $ rend i ts --H
"?" :ts -> cons "?" $ rend i ts --H
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
"{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts
"}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts
"}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts
";" :ts -> cons ";" $ new i $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t : ">" :ts -> cons t $ cons ">" $ rend i ts --H
t : "." :ts -> cons t $ cons "." $ rend i ts --H
t :ts -> realspace t $ rend i ts --H
_ -> ""
cons s t = s ++ t
space t s = t ++ " " ++ s --H
realspace t s = if null s then t else t ++ " " ++ s --H
new i s = s --H '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
realnew s = '\n':s --H
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concat . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Integer where
prt _ = (:[]) . show
instance Print Double where
prt _ = (:[]) . show
instance Print Char where
prt _ s = ["'" ++ mkEsc s ++ "'"]
prtList s = ["\"" ++ concatMap mkEsc s ++ "\""]
mkEsc s = case s of
_ | elem s "\\\"'" -> '\\':[s]
'\n' -> "\\n"
'\t' -> "\\t"
_ -> [s]
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j<i then parenth else id
instance Print Ident where
prt _ i = [prIdent i]
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
instance Print Canon where
prt i e = case e of
Gr modules -> prPrec i 0 (concat [prt 0 modules])
instance Print Module where
prt i e = case e of
Mod modtype extend open flags defs -> prPrec i 0 (concat [prt 0 modtype , ["="] , prt 0 extend , prt 0 open , ["{"] , prt 0 flags , prt 0 defs , ["}"]])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print ModType where
prt i e = case e of
MTAbs id -> prPrec i 0 (concat [["abstract"] , prt 0 id])
MTCnc id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id])
MTRes id -> prPrec i 0 (concat [["resource"] , prt 0 id])
instance Print Extend where
prt i e = case e of
Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]])
NoExt -> prPrec i 0 (concat [])
instance Print Open where
prt i e = case e of
NoOpens -> prPrec i 0 (concat [])
Opens ids -> prPrec i 0 (concat [["open"] , prt 0 ids , ["in"]])
instance Print Flag where
prt i e = case e of
Flg id0 id -> prPrec i 0 (concat [["flags"] , prt 0 id0 , ["="] , prt 0 id])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Def where
prt i e = case e of
AbsDCat id decls cidents -> prPrec i 0 (concat [["cat"] , prt 0 id , ["["] , prt 0 decls , ["]"] , ["="] , prt 0 cidents])
AbsDFun id exp0 exp -> prPrec i 0 (concat [["fun"] , prt 0 id , [":"] , prt 0 exp0 , ["="] , prt 0 exp])
ResDPar id pardefs -> prPrec i 0 (concat [["param"] , prt 0 id , ["="] , prt 0 pardefs])
ResDOper id ctype term -> prPrec i 0 (concat [["oper"] , prt 0 id , [":"] , prt 0 ctype , ["="] , prt 0 term])
CncDCat id ctype term0 term -> prPrec i 0 (concat [["lincat"] , prt 0 id , ["="] , prt 0 ctype , ["="] , prt 0 term0 , [";"] , prt 0 term])
CncDFun id cident argvars term0 term -> prPrec i 0 (concat [["lin"] , prt 0 id , [":"] , prt 0 cident , ["="] , ["\\"] , prt 0 argvars , ["->"] , prt 0 term0 , [";"] , prt 0 term])
AnyDInd id0 status id -> prPrec i 0 (concat [prt 0 id0 , prt 0 status , ["in"] , prt 0 id])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , [";","NEW"] , prt 0 xs]) --H
instance Print ParDef where
prt i e = case e of
ParD id ctypes -> prPrec i 0 (concat [prt 0 id , prt 0 ctypes])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
instance Print Status where
prt i e = case e of
Canon -> prPrec i 0 (concat [["data"]])
NonCan -> prPrec i 0 (concat [])
instance Print CIdent where
prt i e = case e of
CIQ id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print Exp where
prt i e = case e of
EApp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , prt 2 exp])
EProd id exp0 exp -> prPrec i 0 (concat [["("] , prt 0 id , [":"] , prt 0 exp0 , [")"] , ["->"] , prt 0 exp])
EAtom atom -> prPrec i 2 (concat [prt 0 atom])
EAbs id exp -> prPrec i 0 (concat [["\\"] , prt 0 id , ["->"] , prt 0 exp])
EEq equations -> prPrec i 0 (concat [["{"] , prt 0 equations , ["}"]])
instance Print Sort where
prt i e = case e of
SType -> prPrec i 0 (concat [["Type"]])
instance Print Equation where
prt i e = case e of
Equ apatts exp -> prPrec i 0 (concat [prt 0 apatts , ["->"] , prt 0 exp])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print APatt where
prt i e = case e of
APC cident apatts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 apatts , [")"]])
APV id -> prPrec i 0 (concat [prt 0 id])
APS str -> prPrec i 0 (concat [prt 0 str])
API n -> prPrec i 0 (concat [prt 0 n])
APW -> prPrec i 0 (concat [["_"]])
prtList es = case es of
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print Atom where
prt i e = case e of
AC cident -> prPrec i 0 (concat [prt 0 cident])
AD cident -> prPrec i 0 (concat [["<"] , prt 0 cident , [">"]])
AV id -> prPrec i 0 (concat [["$"] , prt 0 id])
AM n -> prPrec i 0 (concat [["?"] , prt 0 n])
AS str -> prPrec i 0 (concat [prt 0 str])
AI n -> prPrec i 0 (concat [prt 0 n])
AT sort -> prPrec i 0 (concat [prt 0 sort])
instance Print Decl where
prt i e = case e of
Decl id exp -> prPrec i 0 (concat [prt 0 id , [":"] , prt 0 exp])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print CType where
prt i e = case e of
RecType labellings -> prPrec i 0 (concat [["{"] , prt 0 labellings , ["}"]])
Table ctype0 ctype -> prPrec i 0 (concat [["("] , prt 0 ctype0 , ["=>"] , prt 0 ctype , [")"]])
Cn cident -> prPrec i 0 (concat [prt 0 cident])
TStr -> prPrec i 0 (concat [["Str"]])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print Labelling where
prt i e = case e of
Lbg label ctype -> prPrec i 0 (concat [prt 0 label , [":"] , prt 0 ctype])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Term where
prt i e = case e of
Arg argvar -> prPrec i 2 (concat [prt 0 argvar])
I cident -> prPrec i 2 (concat [prt 0 cident])
Con cident terms -> prPrec i 2 (concat [["<"] , prt 0 cident , prt 2 terms , [">"]])
LI id -> prPrec i 2 (concat [["$"] , prt 0 id])
R assigns -> prPrec i 2 (concat [["{"] , prt 0 assigns , ["}"]])
P term label -> prPrec i 1 (concat [prt 2 term , ["."] , prt 0 label])
T ctype cases -> prPrec i 1 (concat [["table"] , prt 0 ctype , ["{"] , prt 0 cases , ["}"]])
S term0 term -> prPrec i 1 (concat [prt 1 term0 , ["!"] , prt 2 term])
C term0 term -> prPrec i 0 (concat [prt 0 term0 , ["++"] , prt 1 term])
FV terms -> prPrec i 1 (concat [["variants"] , ["{"] , prt 2 terms , ["}"]])
K tokn -> prPrec i 2 (concat [prt 0 tokn])
E -> prPrec i 2 (concat [["["] , ["]"]])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 2 x , prt 2 xs])
instance Print Tokn where
prt i e = case e of
KS str -> prPrec i 0 (concat [prt 0 str])
KP strs variants -> prPrec i 0 (concat [["["] , ["pre"] , prt 0 strs , ["{"] , prt 0 variants , ["}"] , ["]"]])
instance Print Assign where
prt i e = case e of
Ass label term -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 term])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Case where
prt i e = case e of
Cas patts term -> prPrec i 0 (concat [prt 0 patts , ["=>"] , prt 0 term])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Variant where
prt i e = case e of
Var strs0 strs -> prPrec i 0 (concat [prt 0 strs0 , ["/"] , prt 0 strs])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Label where
prt i e = case e of
L id -> prPrec i 0 (concat [prt 0 id])
LV n -> prPrec i 0 (concat [["$"] , prt 0 n])
instance Print ArgVar where
prt i e = case e of
A id n -> prPrec i 0 (concat [prt 0 id , ["@"] , prt 0 n])
AB id n0 n -> prPrec i 0 (concat [prt 0 id , ["+"] , prt 0 n0 , ["@"] , prt 0 n])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
instance Print Patt where
prt i e = case e of
PC cident patts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 patts , [")"]])
PV id -> prPrec i 0 (concat [prt 0 id])
PW -> prPrec i 0 (concat [["_"]])
PR pattassigns -> prPrec i 0 (concat [["{"] , prt 0 pattassigns , ["}"]])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print PattAssign where
prt i e = case e of
PAss label patt -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 patt])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

116
src/GF/Canon/Share.hs Normal file
View File

@@ -0,0 +1,116 @@
module Share (shareModule, OptSpec, basicOpt, fullOpt) where
import AbsGFC
import Ident
import GFC
import qualified CMacros as C
import Operations
import List
import qualified Modules as M
-- optimization: sharing branches in tables. AR 25/4/2003
-- following advice of Josef Svenningsson
type OptSpec = [Integer] ---
doOptFactor opt = elem 2 opt
basicOpt = []
fullOpt = [2]
shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo)
shareModule opt (i,m) = case m of
M.ModMod (M.Module mt fs me ops js) ->
(i,M.ModMod (M.Module mt fs me ops (mapTree (shareInfo opt) js)))
_ -> (i,m)
shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOpt opt t) m)
shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOpt opt t) m)
shareInfo _ i = i
-- the function putting together optimizations
shareOpt :: OptSpec -> Term -> Term
shareOpt opt
| doOptFactor opt = share . factor 0
| otherwise = share
-- we need no counter to create new variable names, since variables are
-- local to tables
share :: Term -> Term
share t = case t of
T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant.
R lts -> R [Ass l (share t) | Ass l t <- lts]
P t l -> P (share t) l
S t a -> S (share t) (share a)
C t a -> C (share t) (share a)
FV ts -> FV (map share ts)
_ -> t -- including D, which is always born shared
where
shareT ty = finalize ty . groupC . sortC
sortC :: [(Patt,Term)] -> [(Patt,Term)]
sortC = sortBy $ \a b -> compare (snd a) (snd b)
groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
groupC = groupBy $ \a b -> snd a == snd b
finalize :: CType -> [[(Patt,Term)]] -> Term
finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css]
-- do even more: factor parametric branches
factor :: Int -> Term -> Term
factor 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
where
factors i psvs = -- we know psvs has at least 2 elements
let p = pIdent i
vs' = map (mkFun p) psvs
in if allEqs vs'
then mkCase p vs'
else psvs
mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val
allEqs (v:vs) = all (==v) vs
mkCase p (v:_) = [Cas [PV p] v]
pIdent i = identC ("p__" ++ show i)
-- we need to replace subterms
replace :: Term -> Term -> Term -> Term
replace old new trm = case trm of
T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs]
P t l -> P (repl t) l
S t a -> S (repl t) (repl a)
C t a -> C (repl t) (repl a)
FV ts -> FV (map repl ts)
-- these are the important cases, since they can correspond to patterns
Con c ts | trm == old -> new
Con c ts -> Con c (map repl ts)
R _ | isRec && trm == old -> new
R lts -> R [Ass l (repl t) | Ass l t <- lts]
_ -> trm
where
repl = replace old new
isRec = case trm of
R _ -> True
_ -> False

199
src/GF/Canon/SkelGFC.hs Normal file
View File

@@ -0,0 +1,199 @@
module SkelGFC where
import Ident
-- Haskell module generated by the BNF converter
import AbsGFC
import ErrM
type Result = Err String
failure :: Show a => a -> Result
failure x = Bad $ "Undefined case: " ++ show x
transIdent :: Ident -> Result
transIdent x = case x of
_ -> failure x
transCanon :: Canon -> Result
transCanon x = case x of
Gr modules -> failure x
transModule :: Module -> Result
transModule x = case x of
Mod modtype extend open flags defs -> failure x
transModType :: ModType -> Result
transModType x = case x of
MTAbs id -> failure x
MTCnc id0 id -> failure x
MTRes id -> failure x
transExtend :: Extend -> Result
transExtend x = case x of
Ext id -> failure x
NoExt -> failure x
transOpen :: Open -> Result
transOpen x = case x of
NoOpens -> failure x
Opens ids -> failure x
transFlag :: Flag -> Result
transFlag x = case x of
Flg id0 id -> failure x
transDef :: Def -> Result
transDef x = case x of
AbsDCat id decls cidents -> failure x
AbsDFun id exp0 exp -> failure x
ResDPar id pardefs -> failure x
ResDOper id ctype term -> failure x
CncDCat id ctype term0 term -> failure x
CncDFun id cident argvars term0 term -> failure x
AnyDInd id0 status id -> failure x
transParDef :: ParDef -> Result
transParDef x = case x of
ParD id ctypes -> failure x
transStatus :: Status -> Result
transStatus x = case x of
Canon -> failure x
NonCan -> failure x
transCIdent :: CIdent -> Result
transCIdent x = case x of
CIQ id0 id -> failure x
transExp :: Exp -> Result
transExp x = case x of
EApp exp0 exp -> failure x
EProd id exp0 exp -> failure x
EAbs id exp -> failure x
EAtom atom -> failure x
EEq equations -> failure x
transSort :: Sort -> Result
transSort x = case x of
SType -> failure x
transEquation :: Equation -> Result
transEquation x = case x of
Equ apatts exp -> failure x
transAPatt :: APatt -> Result
transAPatt x = case x of
APC cident apatts -> failure x
APV id -> failure x
APS str -> failure x
API n -> failure x
APW -> failure x
transAtom :: Atom -> Result
transAtom x = case x of
AC cident -> failure x
AD cident -> failure x
AV id -> failure x
AM n -> failure x
AS str -> failure x
AI n -> failure x
AT sort -> failure x
transDecl :: Decl -> Result
transDecl x = case x of
Decl id exp -> failure x
transCType :: CType -> Result
transCType x = case x of
RecType labellings -> failure x
Table ctype0 ctype -> failure x
Cn cident -> failure x
TStr -> failure x
transLabelling :: Labelling -> Result
transLabelling x = case x of
Lbg label ctype -> failure x
transTerm :: Term -> Result
transTerm x = case x of
Arg argvar -> failure x
I cident -> failure x
Con cident terms -> failure x
LI id -> failure x
R assigns -> failure x
P term label -> failure x
T ctype cases -> failure x
S term0 term -> failure x
C term0 term -> failure x
FV terms -> failure x
K tokn -> failure x
E -> failure x
transTokn :: Tokn -> Result
transTokn x = case x of
KS str -> failure x
KP strs variants -> failure x
transAssign :: Assign -> Result
transAssign x = case x of
Ass label term -> failure x
transCase :: Case -> Result
transCase x = case x of
Cas patts term -> failure x
transVariant :: Variant -> Result
transVariant x = case x of
Var strs0 strs -> failure x
transLabel :: Label -> Result
transLabel x = case x of
L id -> failure x
LV n -> failure x
transArgVar :: ArgVar -> Result
transArgVar x = case x of
A id n -> failure x
AB id n0 n -> failure x
transPatt :: Patt -> Result
transPatt x = case x of
PC cident patts -> failure x
PV id -> failure x
PW -> failure x
PR pattassigns -> failure x
transPattAssign :: PattAssign -> Result
transPattAssign x = case x of
PAss label patt -> failure x

25
src/GF/Canon/TestGFC.hs Normal file
View File

@@ -0,0 +1,25 @@
-- automatically generated by BNF Converter
module TestGFC where
import LexGFC
import ParGFC
import SkelGFC
import PrintGFC
import AbsGFC
import ErrM
type ParseFun a = [Token] -> Err a
myLLexer = myLexer
runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO()
runFile p f = readFile f >>= run p
run :: (Print a, Show a) => ParseFun a -> String -> IO()
run p s = case (p (myLLexer s)) of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree

37
src/GF/Canon/Unlex.hs Normal file
View File

@@ -0,0 +1,37 @@
module Unlex where
import Operations
import Str
import Char
import List (isPrefixOf)
-- elementary text postprocessing. AR 21/11/2001
formatAsText :: String -> String
formatAsText = unwords . format . cap . words where
format ws = case ws of
w : c : ww | major c -> (w ++ c) : format (cap ww)
w : c : ww | minor c -> (w ++ c) : format ww
c : ww | para c -> "\n\n" : format ww
w : ww -> w : format ww
[] -> []
cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww
cap ((c:cs):ww) = (toUpper c : cs) : ww
cap [] = []
major = flip elem (map (:[]) ".!?")
minor = flip elem (map (:[]) ",:;")
para = (=="<p>")
unlex :: [Str] -> String
unlex = formatAsText . performBinds . concat . map sstr . take 1 ----
-- modified from GF/src/Text by adding hyphen
performBinds :: String -> String
performBinds = unwords . format . words where
format ws = case ws of
w : "-" : u : ws -> format ((w ++ "-" ++ u) : ws)
w : "&+" : u : ws -> format ((w ++ u) : ws)
w : ws -> w : format ws
[] -> []