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

restructured some of the new GF format; modules now in place up to gfo generation

Browse Source
This commit is contained in:
aarne
2007-12-07 20:47:58 +00:00
parent 8437e6d295
commit d9521d2f4c
23 changed files with 403 additions and 427 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/GF/Devel/Grammar/AppPredefined.hs
View File

@@ -18,7 +18,8 @@ module GF.Devel.Grammar.AppPredefined (
appPredefined
) where
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF (prt,prt_,prtBad)
import GF.Infra.Ident

4
src/GF/Devel/Grammar/Compute.hs
View File

@@ -18,8 +18,8 @@ module GF.Devel.Grammar.Compute (
computeTermRec
) where
import GF.Devel.Grammar.Modules
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Lookup
import GF.Devel.Grammar.PrGF

216
src/GF/Devel/Grammar/Construct.hs Normal file
View File

@@ -0,0 +1,216 @@
module GF.Devel.Grammar.Construct where
import GF.Devel.Grammar.Grammar
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map
import Debug.Trace (trace)
------------------
-- abstractions on Grammar
------------------
-- abstractions on GF
emptyGF :: GF
emptyGF = GF Nothing [] empty empty
type SourceModule = (Ident,Module)
listModules :: GF -> [SourceModule]
listModules = assocs.gfmodules
addModule :: Ident -> Module -> GF -> GF
addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
-- abstractions on Module
emptyModule :: Ident -> Module
emptyModule m = Module MTGrammar True [] [] [] [] empty empty
isCompleteModule :: Module -> Bool
isCompleteModule = miscomplete
isInterface :: Module -> Bool
isInterface m = case mtype m of
MTInterface -> True
MTAbstract -> True
_ -> False
interfaceName :: Module -> Maybe Ident
interfaceName mo = case mtype mo of
MTInstance i -> return i
MTConcrete i -> return i
_ -> Nothing
listJudgements :: Module -> [(Ident,Judgement)]
listJudgements = assocs . mjments
isInherited :: MInclude -> Ident -> Bool
isInherited mi i = case mi of
MIExcept is -> notElem i is
MIOnly is -> elem i is
_ -> True
-- abstractions on Judgement
isConstructor :: Judgement -> Bool
isConstructor j = jdef j == EData
isLink :: Judgement -> Bool
isLink j = jform j == JLink
-- constructing judgements from parse tree
emptyJudgement :: JudgementForm -> Judgement
emptyJudgement form = Judgement form meta meta meta (identC "#NOLINK") 0 where
meta = Meta 0
addJType :: Type -> Judgement -> Judgement
addJType tr ju = ju {jtype = tr}
addJDef :: Term -> Judgement -> Judgement
addJDef tr ju = ju {jdef = tr}
addJPrintname :: Term -> Judgement -> Judgement
addJPrintname tr ju = ju {jprintname = tr}
linkInherited :: Bool -> Ident -> Judgement
linkInherited can mo = (emptyJudgement JLink){
jlink = mo,
jdef = if can then EData else Meta 0
}
absCat :: Context -> Judgement
absCat co = addJType (mkProd co typeType) (emptyJudgement JCat)
absFun :: Type -> Judgement
absFun ty = addJType ty (emptyJudgement JFun)
cncCat :: Type -> Judgement
cncCat ty = addJType ty (emptyJudgement JLincat)
cncFun :: Term -> Judgement
cncFun tr = addJDef tr (emptyJudgement JLin)
resOperType :: Type -> Judgement
resOperType ty = addJType ty (emptyJudgement JOper)
resOperDef :: Term -> Judgement
resOperDef tr = addJDef tr (emptyJudgement JOper)
resOper :: Type -> Term -> Judgement
resOper ty tr = addJDef tr (resOperType ty)
resOverload :: [(Type,Term)] -> Judgement
resOverload tts = resOperDef (Overload tts)
-- param p = ci gi is encoded as p : ((ci : gi) -> EData) -> Type
-- we use EData instead of p to make circularity check easier
resParam :: [(Ident,Context)] -> Judgement
resParam cos = addJType constrs (emptyJudgement JParam) where
constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType
-- to enable constructor type lookup:
-- create an oper for each constructor p = c g, as c : g -> p = EData
paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)]
paramConstructors p cs =
[(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs]
-- unifying contents of judgements
---- used in SourceToGF; make error-free and informative
unifyJudgements j k = case unifyJudgement j k of
Ok l -> l
Bad s -> error s
unifyJudgement :: Judgement -> Judgement -> Err Judgement
unifyJudgement old new = do
testErr (jform old == jform new) "different judment forms"
[jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname]
return $ old{jtype = jty, jdef = jde, jprintname = jpri}
where
unifyField field = unifyTerm (field old) (field new)
unifyTerm oterm nterm = case (oterm,nterm) of
(Meta _,t) -> return t
(t,Meta _) -> return t
_ -> do
if (nterm /= oterm)
then (trace (unwords ["illegal update of",show oterm,"to",show nterm])
(return ()))
else return () ---- to recover from spurious qualification conflicts
---- testErr (nterm == oterm)
---- (unwords ["illegal update of",prt oterm,"to",prt nterm])
return nterm
-- abstractions on Term
type Cat = QIdent
type Fun = QIdent
type QIdent = (Ident,Ident)
-- | branches à la Alfa
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
wildPatt :: Patt
wildPatt = PW
type Trm = Term
mkProd :: Context -> Type -> Type
mkProd = flip (foldr (uncurry Prod))
-- type constants
typeType :: Type
typeType = Sort "Type"
typePType :: Type
typePType = Sort "PType"
typeStr :: Type
typeStr = Sort "Str"
typeTok :: Type ---- deprecated
typeTok = Sort "Tok"
cPredef :: Ident
cPredef = identC "Predef"
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
cnPredef = constPredefRes
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (identC s)
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
_ -> False

319
src/GF/Devel/Grammar/GF.cf
View File

@@ -1,319 +0,0 @@
-- AR 2/5/2003, 14-16 o'clock, Torino
-- 17/6/2007: marked with suffix --% those lines that are obsolete and
-- should not be included in documentation
entrypoints Grammar, ModDef,
OldGrammar, --%
Exp ; -- let's see if more are needed
comment "--" ;
comment "{-" "-}" ;
-- identifiers
position token PIdent (letter | '_') (letter | digit | '_' | '\'')* ;
-- the top-level grammar
Gr. Grammar ::= [ModDef] ;
-- semicolon after module is permitted but not obligatory
terminator ModDef "" ;
_. ModDef ::= ModDef ";" ;
-- the individual modules
MModule. ModDef ::= ComplMod ModType "=" ModBody ;
MAbstract. ModType ::= "abstract" PIdent ;
MResource. ModType ::= "resource" PIdent ;
MGrammar. ModType ::= "grammar" PIdent ;
MInterface. ModType ::= "interface" PIdent ;
MConcrete. ModType ::= "concrete" PIdent "of" PIdent ;
MInstance. ModType ::= "instance" PIdent "of" PIdent ;
MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ;
MNoBody. ModBody ::= [Included] ;
MWith. ModBody ::= Included "with" [Open] ;
MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MWithE. ModBody ::= [Included] "**" Included "with" [Open] ;
MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MReuse. ModBody ::= "reuse" PIdent ; --%
MUnion. ModBody ::= "union" [Included] ;--%
separator TopDef "" ;
Ext. Extend ::= [Included] "**" ;
NoExt. Extend ::= ;
separator Open "," ;
NoOpens. Opens ::= ;
OpenIn. Opens ::= "open" [Open] "in" ;
OName. Open ::= PIdent ;
-- OQualQO. Open ::= "(" PIdent ")" ; --%
OQual. Open ::= "(" PIdent "=" PIdent ")" ;
CMCompl. ComplMod ::= ;
CMIncompl. ComplMod ::= "incomplete" ;
separator Included "," ;
IAll. Included ::= PIdent ;
ISome. Included ::= PIdent "[" [PIdent] "]" ;
IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ;
-- top-level definitions
DefCat. TopDef ::= "cat" [CatDef] ;
DefFun. TopDef ::= "fun" [FunDef] ;
DefFunData.TopDef ::= "data" [FunDef] ;
DefDef. TopDef ::= "def" [Def] ;
DefData. TopDef ::= "data" [DataDef] ;
DefPar. TopDef ::= "param" [ParDef] ;
DefOper. TopDef ::= "oper" [Def] ;
DefLincat. TopDef ::= "lincat" [Def] ;
DefLindef. TopDef ::= "lindef" [Def] ;
DefLin. TopDef ::= "lin" [Def] ;
DefPrintCat. TopDef ::= "printname" "cat" [Def] ;
DefPrintFun. TopDef ::= "printname" "fun" [Def] ;
DefFlag. TopDef ::= "flags" [Def] ;
-- definitions after most keywords
DDecl. Def ::= [Name] ":" Exp ;
DDef. Def ::= [Name] "=" Exp ;
DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list
DFull. Def ::= [Name] ":" Exp "=" Exp ;
FDecl. FunDef ::= [Name] ":" Exp ;
SimpleCatDef. CatDef ::= PIdent [DDecl] ;
ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ;
ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ;
DataDef. DataDef ::= Name "=" [DataConstr] ;
DataId. DataConstr ::= PIdent ;
DataQId. DataConstr ::= PIdent "." PIdent ;
separator DataConstr "|" ;
ParDefDir. ParDef ::= PIdent "=" [ParConstr] ;
ParDefAbs. ParDef ::= PIdent ;
ParConstr. ParConstr ::= PIdent [DDecl] ;
terminator nonempty Def ";" ;
terminator nonempty FunDef ";" ;
terminator nonempty CatDef ";" ;
terminator nonempty DataDef ";" ;
terminator nonempty ParDef ";" ;
separator ParConstr "|" ;
separator nonempty PIdent "," ;
-- names of categories and functions in definition LHS
PIdentName. Name ::= PIdent ;
ListName. Name ::= "[" PIdent "]" ;
separator nonempty Name "," ;
-- definitions in records and $let$ expressions
LDDecl. LocDef ::= [PIdent] ":" Exp ;
LDDef. LocDef ::= [PIdent] "=" Exp ;
LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ;
separator LocDef ";" ;
-- terms and types
EPIdent. Exp6 ::= PIdent ;
EConstr. Exp6 ::= "{" PIdent "}" ;--%
ECons. Exp6 ::= "%" PIdent "%" ;--%
ESort. Exp6 ::= Sort ;
EString. Exp6 ::= String ;
EInt. Exp6 ::= Integer ;
EFloat. Exp6 ::= Double ;
EMeta. Exp6 ::= "?" ;
EEmpty. Exp6 ::= "[" "]" ;
EData. Exp6 ::= "data" ;
EList. Exp6 ::= "[" PIdent Exps "]" ;
EStrings. Exp6 ::= "[" String "]" ;
ERecord. Exp6 ::= "{" [LocDef] "}" ; -- !
ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator ","
EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --%
ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations
EProj. Exp5 ::= Exp5 "." Label ;
EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --%
EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --%
EApp. Exp4 ::= Exp4 Exp5 ;
ETable. Exp4 ::= "table" "{" [Case] "}" ;
ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ;
EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
EStrs. Exp4 ::= "strs" "{" [Exp] "}" ;
ESelect. Exp3 ::= Exp3 "!" Exp4 ;
ETupTyp. Exp3 ::= Exp3 "*" Exp4 ;
EExtend. Exp3 ::= Exp3 "**" Exp4 ;
EGlue. Exp1 ::= Exp2 "+" Exp1 ;
EConcat. Exp ::= Exp1 "++" Exp ;
EAbstr. Exp ::= "\\" [Bind] "->" Exp ;
ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ;
EProd. Exp ::= Decl "->" Exp ;
ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative
ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ;
ELetb. Exp ::= "let" [LocDef] "in" Exp ;
EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ;
EEqs. Exp ::= "fn" "{" [Equation] "}" ; --%
EExample. Exp ::= "in" Exp5 String ;
coercions Exp 6 ;
separator Exp ";" ; -- in variants
-- list of arguments to category
NilExp. Exps ::= ;
ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses
-- patterns
PW. Patt2 ::= "_" ;
PV. Patt2 ::= PIdent ;
PCon. Patt2 ::= "{" PIdent "}" ; --%
PQ. Patt2 ::= PIdent "." PIdent ;
PInt. Patt2 ::= Integer ;
PFloat. Patt2 ::= Double ;
PStr. Patt2 ::= String ;
PR. Patt2 ::= "{" [PattAss] "}" ;
PTup. Patt2 ::= "<" [PattTupleComp] ">" ;
PC. Patt1 ::= PIdent [Patt] ;
PQC. Patt1 ::= PIdent "." PIdent [Patt] ;
PDisj. Patt ::= Patt "|" Patt1 ;
PSeq. Patt ::= Patt "+" Patt1 ;
PRep. Patt1 ::= Patt2 "*" ;
PAs. Patt1 ::= PIdent "@" Patt2 ;
PNeg. Patt1 ::= "-" Patt2 ;
coercions Patt 2 ;
PA. PattAss ::= [PIdent] "=" Patt ;
-- labels
LPIdent. Label ::= PIdent ;
LVar. Label ::= "$" Integer ;
-- basic types
rules Sort ::=
"Type"
| "PType"
| "Tok" --%
| "Str"
| "Strs" ;
separator PattAss ";" ;
-- this is explicit to force higher precedence level on rhs
(:[]). [Patt] ::= Patt2 ;
(:). [Patt] ::= Patt2 [Patt] ;
-- binds in lambdas and lin rules
BPIdent. Bind ::= PIdent ;
BWild. Bind ::= "_" ;
separator Bind "," ;
-- declarations in function types
DDec. Decl ::= "(" [Bind] ":" Exp ")" ;
DExp. Decl ::= Exp4 ; -- can thus be an application
-- tuple component (term or pattern)
TComp. TupleComp ::= Exp ;
PTComp. PattTupleComp ::= Patt ;
separator TupleComp "," ;
separator PattTupleComp "," ;
-- case branches
Case. Case ::= Patt "=>" Exp ;
separator nonempty Case ";" ;
-- cases in abstract syntax --%
Equ. Equation ::= [Patt] "->" Exp ; --%
separator Equation ";" ; --%
-- prefix alternatives
Alt. Altern ::= Exp "/" Exp ;
separator Altern ";" ;
-- in a context, higher precedence is required than in function types
DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ;
DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application
separator DDecl "" ;
-------------------------------------- --%
-- for backward compatibility --%
OldGr. OldGrammar ::= Include [TopDef] ; --%
NoIncl. Include ::= ; --%
Incl. Include ::= "include" [FileName] ; --%
FString. FileName ::= String ; --%
terminator nonempty FileName ";" ; --%
FPIdent. FileName ::= PIdent ; --%
FSlash. FileName ::= "/" FileName ; --%
FDot. FileName ::= "." FileName ; --%
FMinus. FileName ::= "-" FileName ; --%
FAddId. FileName ::= PIdent FileName ; --%
token LString '\'' (char - '\'')* '\'' ; --%
ELString. Exp6 ::= LString ; --%
ELin. Exp4 ::= "Lin" PIdent ; --%
DefPrintOld. TopDef ::= "printname" [Def] ; --%
DefLintype. TopDef ::= "lintype" [Def] ; --%
DefPattern. TopDef ::= "pattern" [Def] ; --%
-- deprecated packages are attempted to be interpreted --%
DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --%
-- these two are just ignored after parsing --%
DefVars. TopDef ::= "var" [Def] ; --%
DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --%

10
src/GF/Devel/Grammar/GFtoSource.hs
View File

@@ -9,11 +9,10 @@ module GF.Devel.Grammar.GFtoSource (
) where
import GF.Devel.Grammar.Modules
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros (contextOfType)
import qualified GF.Devel.Grammar.AbsGF as P
import qualified GF.Devel.Compile.AbsGF as P
import GF.Infra.Ident
import GF.Data.Operations
@@ -43,7 +42,7 @@ trModule (i,mo) = P.MModule compl typ body where
body = P.MBody
(trExtends (mextends mo))
(mkOpens (map trOpen (mopens mo)))
(concatMap trAnyDef [(c,j) | (c,Left j) <- listJudgements mo] ++
(concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++
map trFlag (Map.assocs (mflags mo)))
trExtends :: [(Ident,MInclude)] -> P.Extend
@@ -89,6 +88,7 @@ trAnyDef (i,ju) = let
JLin ->
[P.DefLin [trDef i (Meta 0) (jdef ju)]]
---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
JLink -> []
{-
---- encoding of AnyInd without changing syntax. AR 20/9/2007
AnyInd s b ->

77
src/GF/Devel/Grammar/Terms.hs → src/GF/Devel/Grammar/Grammar.hs
View File

@@ -1,14 +1,69 @@
module GF.Devel.Grammar.Terms where
module GF.Devel.Grammar.Grammar where
import GF.Infra.Ident
import GF.Data.Operations
type Type = Term
type Cat = QIdent
type Fun = QIdent
import Data.Map
type QIdent = (Ident,Ident)
------------------
-- definitions --
------------------
data GF = GF {
gfabsname :: Maybe Ident ,
gfcncnames :: [Ident] ,
gflags :: Map Ident String , -- value of a global flag
gfmodules :: Map Ident Module
}
data Module = Module {
mtype :: ModuleType,
miscomplete :: Bool,
minterfaces :: [(Ident,Ident)], -- non-empty for functors
minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions
mextends :: [(Ident,MInclude)],
mopens :: [(Ident,Ident)], -- used name, original name
mflags :: Map Ident String,
mjments :: Map Ident Judgement
}
data ModuleType =
MTAbstract
| MTConcrete Ident
| MTInterface
| MTInstance Ident
| MTGrammar
deriving Eq
data MInclude =
MIAll
| MIExcept [Ident]
| MIOnly [Ident]
type Indirection = (Ident,Bool) -- module of origin, whether canonical
data Judgement = Judgement {
jform :: JudgementForm, -- cat fun lincat lin oper param
jtype :: Type, -- context type lincat - type constrs
jdef :: Term, -- lindef def lindef lin def values
jprintname :: Term, -- - - prname prname - -
jlink :: Ident,
jposition :: Int
}
data JudgementForm =
JCat
| JFun
| JLincat
| JLin
| JOper
| JParam
| JLink
deriving Eq
type Type = Term
data Term =
Vr Ident -- ^ variable
@@ -104,15 +159,3 @@ type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term)
type LocalDef = (Ident, (Maybe Type, Term))
-- | branches à la Alfa
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
wildPatt :: Patt
wildPatt = PW
type Trm = Term

21
src/GF/Devel/Grammar/Judgements.hs
View File

@@ -1,21 +0,0 @@
module GF.Devel.Grammar.Judgements where
import GF.Devel.Grammar.Terms
import GF.Infra.Ident
data Judgement = Judgement {
jform :: JudgementForm, -- cat fun lincat lin oper param
jtype :: Type, -- context type lincat - type constrs
jdef :: Term, -- lindef def lindef lin def values
jprintname :: Term -- - - prname prname - -
}
data JudgementForm =
JCat
| JFun
| JLincat
| JLin
| JOper
| JParam
deriving Eq

17
src/GF/Devel/Grammar/Lookup.hs
View File

@@ -1,9 +1,8 @@
module GF.Devel.Grammar.Lookup where
import GF.Devel.Grammar.Modules
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident
@@ -103,15 +102,19 @@ lookupModule :: GF -> Ident -> Err Module
lookupModule gf m = do
maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf)
lookupIdent :: GF -> Ident -> Ident -> Err JEntry
-- this finds the immediate definition, which can be a link
lookupIdent :: GF -> Ident -> Ident -> Err Judgement
lookupIdent gf m c = do
mo <- lookupModule gf m
maybe (raiseIdent "constant not found" c) return $ mlookup c (mjments mo)
maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo)
-- this follows the link
lookupJudgement :: GF -> Ident -> Ident -> Err Judgement
lookupJudgement gf m c = do
eji <- lookupIdent gf m c
either return (\n -> lookupJudgement gf (fst n) c) eji
ju <- lookupIdent gf m c
case jform ju of
JLink -> lookupJudgement gf (jlink ju) c
_ -> return ju
mlookup = Data.Map.lookup

58
src/GF/Devel/Grammar/Macros.hs
View File

@@ -1,8 +1,7 @@
module GF.Devel.Grammar.Macros where
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Modules
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Infra.Ident
import GF.Data.Str
@@ -81,9 +80,6 @@ typeSkeleton typ = do
-- construct types and terms
mkProd :: Context -> Type -> Type
mkProd = flip (foldr (uncurry Prod))
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod
@@ -156,49 +152,6 @@ plusRecord t1 t2 =
zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
-- type constants
typeType :: Type
typeType = Sort "Type"
typePType :: Type
typePType = Sort "PType"
typeStr :: Type
typeStr = Sort "Str"
typeTok :: Type ---- deprecated
typeTok = Sort "Tok"
cPredef :: Ident
cPredef = identC "Predef"
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
cnPredef = constPredefRes
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (identC s)
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
_ -> False
defLinType :: Type
defLinType = RecType [(LIdent "s", typeStr)]
@@ -230,10 +183,8 @@ termOpModule f = judgementOpModule fj where
judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module
judgementOpModule f m = do
mjs <- mapMapM fj (mjments m)
mjs <- mapMapM f (mjments m)
return m {mjments = mjs}
where
fj = either (liftM Left . f) (return . Right)
entryOpModule :: Monad m =>
(Ident -> Judgement -> m Judgement) -> Module -> m Module
@@ -241,8 +192,7 @@ entryOpModule f m = do
mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m
return $ m {mjments = mjs}
where
mapm = mapM (\ (i,j) -> liftM ((,) i) (fe i j))
fe i j = either (liftM Left . f i) (return . Right) j
mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j))
termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
termOpJudgement f j = do

93
src/GF/Devel/Grammar/MkJudgements.hs
View File

@@ -1,93 +0,0 @@
module GF.Devel.Grammar.MkJudgements where
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map
import Debug.Trace (trace) ----
-- constructing judgements from parse tree
emptyJudgement :: JudgementForm -> Judgement
emptyJudgement form = Judgement form meta meta meta where
meta = Meta 0
addJType :: Type -> Judgement -> Judgement
addJType tr ju = ju {jtype = tr}
addJDef :: Term -> Judgement -> Judgement
addJDef tr ju = ju {jdef = tr}
addJPrintname :: Term -> Judgement -> Judgement
addJPrintname tr ju = ju {jprintname = tr}
absCat :: Context -> Judgement
absCat co = addJType (mkProd co typeType) (emptyJudgement JCat)
absFun :: Type -> Judgement
absFun ty = addJType ty (emptyJudgement JFun)
cncCat :: Type -> Judgement
cncCat ty = addJType ty (emptyJudgement JLincat)
cncFun :: Term -> Judgement
cncFun tr = addJDef tr (emptyJudgement JLin)
resOperType :: Type -> Judgement
resOperType ty = addJType ty (emptyJudgement JOper)
resOperDef :: Term -> Judgement
resOperDef tr = addJDef tr (emptyJudgement JOper)
resOper :: Type -> Term -> Judgement
resOper ty tr = addJDef tr (resOperType ty)
resOverload :: [(Type,Term)] -> Judgement
resOverload tts = resOperDef (Overload tts)
-- param p = ci gi is encoded as p : ((ci : gi) -> EData) -> Type
-- we use EData instead of p to make circularity check easier
resParam :: [(Ident,Context)] -> Judgement
resParam cos = addJType constrs (emptyJudgement JParam) where
constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType
-- to enable constructor type lookup:
-- create an oper for each constructor p = c g, as c : g -> p = EData
paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)]
paramConstructors p cs =
[(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs]
-- unifying contents of judgements
---- used in SourceToGF; make error-free and informative
unifyJudgements (Left j) (Left k) = Left $ case unifyJudgement j k of
Ok l -> l
Bad s -> error s
unifyJudgement :: Judgement -> Judgement -> Err Judgement
unifyJudgement old new = do
testErr (jform old == jform new) "different judment forms"
[jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname]
return $ old{jtype = jty, jdef = jde, jprintname = jpri}
where
unifyField field = unifyTerm (field old) (field new)
unifyTerm oterm nterm = case (oterm,nterm) of
(Meta _,t) -> return t
(t,Meta _) -> return t
_ -> do
if (nterm /= oterm)
then (trace (unwords ["illegal update of",prt oterm,"to",prt nterm])
(return ()))
else return () ---- to recover from spurious qualification conflicts
---- testErr (nterm == oterm)
---- (unwords ["illegal update of",prt oterm,"to",prt nterm])
return nterm

96
src/GF/Devel/Grammar/Modules.hs
View File

@@ -1,96 +0,0 @@
module GF.Devel.Grammar.Modules where
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Terms
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map
data GF = GF {
gfabsname :: Maybe Ident ,
gfcncnames :: [Ident] ,
gflags :: Map Ident String , -- value of a global flag
gfmodules :: Map Ident Module
}
emptyGF :: GF
emptyGF = GF Nothing [] empty empty
type SourceModule = (Ident,Module)
listModules :: GF -> [SourceModule]
listModules = assocs.gfmodules
addModule :: Ident -> Module -> GF -> GF
addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
data Module = Module {
mtype :: ModuleType,
miscomplete :: Bool,
minterfaces :: [(Ident,Ident)], -- non-empty for functors
minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions
mextends :: [(Ident,MInclude)],
mopens :: [(Ident,Ident)], -- used name, original name
mflags :: Map Ident String,
mjments :: MapJudgement
}
emptyModule :: Ident -> Module
emptyModule m = Module MTGrammar True [] [] [] [] empty empty
type MapJudgement = Map Ident JEntry -- def or indirection
isCompleteModule :: Module -> Bool
isCompleteModule = miscomplete ---- Prelude.null . minterfaces
isInterface :: Module -> Bool
isInterface m = case mtype m of
MTInterface -> True
MTAbstract -> True
_ -> False
interfaceName :: Module -> Maybe Ident
interfaceName mo = case mtype mo of
MTInstance i -> return i
MTConcrete i -> return i
_ -> Nothing
listJudgements :: Module -> [(Ident,JEntry)]
listJudgements = assocs . mjments
type JEntry = Either Judgement Indirection
data ModuleType =
MTAbstract
| MTConcrete Ident
| MTInterface
| MTInstance Ident
| MTGrammar
deriving Eq
data MInclude =
MIAll
| MIExcept [Ident]
| MIOnly [Ident]
type Indirection = (Ident,Bool) -- module of origin, whether canonical
isConstructorEntry :: Either Judgement Indirection -> Bool
isConstructorEntry ji = case ji of
Left j -> isConstructor j
Right i -> snd i
isConstructor :: Judgement -> Bool
isConstructor j = jdef j == EData
isInherited :: MInclude -> Ident -> Bool
isInherited mi i = case mi of
MIExcept is -> notElem i is
MIOnly is -> elem i is
_ -> True

2
src/GF/Devel/Grammar/PatternMatch.hs
View File

@@ -18,7 +18,7 @@ module GF.Devel.Grammar.PatternMatch (matchPattern,
) where
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident

10
src/GF/Devel/Grammar/PrGF.hs
View File

@@ -21,11 +21,10 @@
module GF.Devel.Grammar.PrGF where
import qualified GF.Devel.Grammar.PrintGF as P
import qualified GF.Devel.Compile.PrintGF as P
import GF.Devel.Grammar.GFtoSource
import GF.Devel.Grammar.Modules
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
----import GF.Grammar.Values
----import GF.Infra.Option
@@ -68,9 +67,6 @@ prGF = cprintTree . trGrammar
prModule :: SourceModule -> String
prModule = cprintTree . trModule
prJEntry :: JEntry -> String
prJEntry = either prt show
instance Print Judgement where
prt j = cprintTree $ trAnyDef (wildIdent, j)
---- prt_ = prExp

670
src/GF/Devel/Grammar/SourceToGF.hs
View File

@@ -1,670 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : SourceToGF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/04 11:05:07 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.28 $
--
-- based on the skeleton Haskell module generated by the BNF converter
-----------------------------------------------------------------------------
module GF.Devel.Grammar.SourceToGF (
transGrammar,
transModDef,
transExp,
---- transOldGrammar,
---- transInclude,
newReservedWords
) where
import qualified GF.Devel.Grammar.Terms as G
----import qualified GF.Grammar.PrGrammar as GP
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.MkJudgements
import GF.Devel.Grammar.Modules
import qualified GF.Devel.Grammar.Macros as M
----import qualified GF.Compile.Update as U
--import qualified GF.Infra.Option as GO
--import qualified GF.Compile.ModDeps as GD
import GF.Infra.Ident
import GF.Devel.Grammar.AbsGF
import GF.Devel.Grammar.PrintGF (printTree)
----import GF.Source.PrintGF
----import GF.Compile.RemoveLiT --- for bw compat
import GF.Data.Operations
--import GF.Infra.Option
import Control.Monad
import Data.Char
import qualified Data.Map as Map
import Data.List (genericReplicate)
import Debug.Trace (trace) ----
-- based on the skeleton Haskell module generated by the BNF converter
type Result = Err String
failure :: Show a => a -> Err b
failure x = Bad $ "Undefined case: " ++ show x
getIdentPos :: PIdent -> Err (Ident,Int)
getIdentPos x = case x of
PIdent ((line,_),c) -> return (IC c,line)
transIdent :: PIdent -> Err Ident
transIdent = liftM fst . getIdentPos
transName :: Name -> Err Ident
transName n = case n of
PIdentName i -> transIdent i
ListName i -> transIdent (mkListId i)
transGrammar :: Grammar -> Err GF
transGrammar x = case x of
Gr moddefs -> do
moddefs' <- mapM transModDef moddefs
let mos = Map.fromList moddefs'
return $ emptyGF {gfmodules = mos}
transModDef :: ModDef -> Err (Ident,Module)
transModDef x = case x of
MModule compl mtyp body -> do
let isCompl = transComplMod compl
(trDef, mtyp', id') <- case mtyp of
MAbstract id -> do
id' <- transIdent id
return (transAbsDef, MTAbstract, id')
MGrammar id -> mkModRes id MTGrammar body
MResource id -> mkModRes id MTGrammar body
MConcrete id open -> do
id' <- transIdent id
open' <- transIdent open
return (transCncDef, MTConcrete open', id')
MInterface id -> mkModRes id MTInterface body
MInstance id open -> do
open' <- transIdent open
mkModRes id (MTInstance open') body
mkBody (isCompl, trDef, mtyp', id') body
where
mkBody xx@(isc, trDef, mtyp', id') bod = case bod of
MNoBody incls -> do
mkBody xx $ MBody (Ext incls) NoOpens []
MBody extends opens defs -> do
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
let defs' = Map.fromListWith unifyJudgements
[(i,Left d) | Left ds <- defs0, (i,d) <- ds]
let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
return (id', Module mtyp' isc [] [] extends' opens' flags' defs')
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens []
MWithEBody extends m insts opens defs -> do
extends' <- mapM transIncludedExt extends
m' <- transIncludedExt m
insts' <- mapM transOpen insts
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
let defs' = Map.fromListWith unifyJudgements
[(i,Left d) | Left ds <- defs0, (i,d) <- ds]
let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
return (id', Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs')
_ -> fail "deprecated module form"
mkModRes id mtyp body = do
id' <- transIdent id
return (transResDef, mtyp, id')
getTopDefs :: [TopDef] -> [TopDef]
getTopDefs x = x
transComplMod :: ComplMod -> Bool
transComplMod x = case x of
CMCompl -> True
CMIncompl -> False
transExtend :: Extend -> Err [(Ident,MInclude)]
transExtend x = case x of
Ext ids -> mapM transIncludedExt ids
NoExt -> return []
transOpens :: Opens -> Err [(Ident,Ident)]
transOpens x = case x of
NoOpens -> return []
OpenIn opens -> mapM transOpen opens
transOpen :: Open -> Err (Ident,Ident)
transOpen x = case x of
OName id -> transIdent id >>= \y -> return (y,y)
OQual id m -> liftM2 (,) (transIdent id) (transIdent m)
transIncludedExt :: Included -> Err (Ident, MInclude)
transIncludedExt x = case x of
IAll i -> liftM2 (,) (transIdent i) (return MIAll)
ISome i ids -> liftM2 (,) (transIdent i) (liftM MIOnly $ mapM transIdent ids)
IMinus i ids -> liftM2 (,) (transIdent i) (liftM MIExcept $ mapM transIdent ids)
transAbsDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)])
transAbsDef x = case x of
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
DefFun fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl [(fun, absFun typ) | (funs,typ) <- fundefs', fun <- funs]
{- ----
DefFunData fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl $
[(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs',
fun <- funs,
Ok (_,cat) <- [M.valCat typ]
] ++
[(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs]
DefDef defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs']
DefData ds -> do
ds' <- mapM transDataDef ds
returnl $
[(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
[(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
-}
DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs
_ -> return $ Left [] ----
---- _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where
-- to get data constructors as terms
funs t = case t of
G.Con f -> [f]
G.Q _ f -> [f]
G.QC _ f -> [f]
_ -> []
returnl :: a -> Err (Either a b)
returnl = return . Left
transFlagDef :: Def -> Err [(Ident,String)]
transFlagDef x = case x of
DDef f x -> do
fs <- mapM transName f
x' <- transExp x
v <- case x' of
G.K s -> return s
G.Vr (IC s) -> return s
G.EInt i -> return $ show i
_ -> fail $ "illegal flag value" +++ printTree x
return $ [(f',v) | f' <- fs]
-- | Cat definitions can also return some fun defs
-- if it is a list category definition
transCatDef :: CatDef -> Err [(Ident, Judgement)]
transCatDef x = case x of
SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls
ListCatDef id ddecls -> listCat id ddecls 0
ListSizeCatDef id ddecls size -> listCat id ddecls size
where
cat id ddecls = do
i <- transIdent id
cont <- liftM concat $ mapM transDDecl ddecls
return (i, absCat cont)
listCat id ddecls size = do
let li = mkListId id
li' <- transIdent $ li
baseId <- transIdent $ mkBaseId id
consId <- transIdent $ mkConsId id
catd0@(c,ju) <- cat li ddecls
id' <- transIdent id
let
cont0 = [] ---- cat context
catd = (c,ju) ----(Yes cont0) (Yes [M.cn baseId,M.cn consId]))
cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
xs = map (G.Vr . fst) cont
cd = M.mkDecl (M.mkApp (G.Vr id') xs)
lc = M.mkApp (G.Vr li') xs
niltyp = M.mkProd (cont ++ genericReplicate size cd) lc
nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData))
constyp = M.mkProd (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, absFun constyp) ---- (yes constyp) (yes G.EData))
return [catd,nilfund,consfund]
mkId x i = if isWildIdent x then (mkIdent "x" i) else x
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of
FDecl ids typ -> liftM2 (,) (mapM transName ids) (transExp typ)
{- ----
transDataDef :: DataDef -> Err (Ident,[G.Term])
transDataDef x = case x of
DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds)
where
transData d = case d of
DataId id -> liftM G.Con $ transIdent id
DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id)
-}
transResDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)])
transResDef x = case x of
DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs
returnl $ concatMap mkParamDefs pardefs'
DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl $ concatMap mkOverload [(f, resOper pt pe) | (f,(pt,pe)) <- defs']
DefLintype defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, resOper pt pe) | (f,(pt,pe)) <- defs']
DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition form in resource" +++ printTree x
where
mkParamDefs (p,pars) =
if null pars
then [(p,addJType M.meta0 (emptyJudgement JParam))] -- in an interface
else (p,resParam pars) : paramConstructors p pars
mkOverload (c,j) = case (jtype j, jdef j) of
(_,G.App keyw (G.R fs@(_:_:_))) | isOverloading keyw c fs ->
[(c,resOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])]
-- to enable separare type signature --- not type-checked
(G.App keyw (G.RecType fs@(_:_:_)),_) | isOverloading keyw c fs -> []
_ -> [(c,j)]
isOverloading (G.Vr keyw) c fs =
prIdent keyw == "overload" && -- overload is a "soft keyword"
True ---- all (== GP.prt c) (map (GP.prt . fst) fs)
transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)])
transParDef x = case x of
ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
transCncDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)])
transCncDef x = case x of
DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, cncCat t) | (f,t) <- defs']
---- DefLindef defs -> do
---- defs' <- liftM concat $ mapM getDefs defs
---- returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs']
DefLin defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, cncFun pe) | (f,(_,pe)) <- defs']
{- ----
DefPrintCat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs']
DefPrintFun defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefPrintOld defs -> do --- a guess, for backward compatibility
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefFlag defs -> liftM Right $ mapM transFlagDef defs
DefPattern defs -> do
defs' <- liftM concat $ mapM getDefs defs
let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2]
-}
_ -> errIn ("illegal definition in concrete syntax:") $ transResDef x
transPrintDef :: Def -> Err [(Ident,G.Term)]
transPrintDef x = case x of
DDef ids exp -> do
(ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
return $ [(i,e) | i <- ids]
getDefsGen :: Def -> Err [(Ident, (G.Type, G.Term))]
getDefsGen d = case d of
DDecl ids t -> do
ids' <- mapM transName ids
t' <- transExp t
return [(i,(t', nope)) | i <- ids']
DDef ids e -> do
ids' <- mapM transName ids
e' <- transExp e
return [(i,(nope, yes e')) | i <- ids']
DFull ids t e -> do
ids' <- mapM transName ids
t' <- transExp t
e' <- transExp e
return [(i,(yes t', yes e')) | i <- ids']
DPatt id patts e -> do
id' <- transName id
ps' <- mapM transPatt patts
e' <- transExp e
return [(id',(nope, yes (G.Eqs [(ps',e')])))]
where
yes = id
nope = G.Meta 0
-- | sometimes you need this special case, e.g. in linearization rules
getDefs :: Def -> Err [(Ident, (G.Type, G.Term))]
getDefs d = case d of
DPatt id patts e -> do
id' <- transName id
xs <- mapM tryMakeVar patts
e' <- transExp e
return [(id',(nope, (M.mkAbs xs e')))]
_ -> getDefsGen d
where
nope = G.Meta 0
-- | accepts a pattern that is either a variable or a wild card
tryMakeVar :: Patt -> Err Ident
tryMakeVar p = do
p' <- transPatt p
case p' of
G.PV i -> return i
G.PW -> return identW
_ -> Bad $ "not a legal pattern in lambda binding" +++ show p'
transExp :: Exp -> Err G.Term
transExp x = case x of
EPIdent id -> liftM G.Vr $ transIdent id
EConstr id -> liftM G.Con $ transIdent id
ECons id -> liftM G.Con $ transIdent id
EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c)
EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c)
EString str -> return $ G.K str
ESort sort -> liftM G.Sort $ transSort sort
EInt n -> return $ G.EInt n
EFloat n -> return $ G.EFloat n
EMeta -> return $ G.Meta 0
EEmpty -> return G.Empty
-- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
EList i es -> transExp $ foldl EApp (EPIdent (mkListId i)) (exps2list es)
EStrings [] -> return G.Empty
EStrings str -> return $ foldr1 G.C $ map G.K $ words str
ERecord defs -> erecord2term defs
ETupTyp _ _ -> do
let tups t = case t of
ETupTyp x y -> tups x ++ [y] -- right-associative parsing
_ -> [t]
es <- mapM transExp $ tups x
return $ G.RecType $ [] ---- M.tuple2recordType es
ETuple tuplecomps -> do
es <- mapM transExp [e | TComp e <- tuplecomps]
return $ G.R $ [] ---- M.tuple2record es
EProj exp id -> liftM2 G.P (transExp exp) (trLabel id)
EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp)
ETable cases -> liftM (G.T G.TRaw) (transCases cases)
ETTable exp cases ->
liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
EVTable exp cases ->
liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
ECase exp cases -> do
exp' <- transExp exp
cases' <- transCases cases
let annot = case exp' of
G.Typed _ t -> G.TTyped t
_ -> G.TRaw
return $ G.S (G.T annot cases') exp'
ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
EVariants exps -> liftM G.FV $ mapM transExp exps
EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts)
EStrs exps -> liftM G.FV $ mapM transExp exps
ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp)
EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp)
EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp)
ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp)
EExample exp str -> liftM2 G.Example (transExp exp) (return str)
EProd decl exp -> liftM2 M.mkProd (transDecl decl) (transExp exp)
ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp)
EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp)
EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp)
ELet defs exp -> do
exp' <- transExp exp
defs0 <- mapM locdef2fields defs
defs' <- mapM tryLoc $ concat defs0
return $ M.mkLet defs' exp'
where
tryLoc (c,(mty,Just e)) = return (c,(mty,e))
tryLoc (c,_) = Bad $ "local definition of" +++ prIdent c +++ "without value"
ELetb defs exp -> transExp $ ELet defs exp
EWhere exp defs -> transExp $ ELet defs exp
ELString (LString str) -> return $ G.K str
---- ELin id -> liftM G.LiT $ transIdent id
EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
_ -> Bad $ "translation not yet defined for" +++ printTree x ----
exps2list :: Exps -> [Exp]
exps2list NilExp = []
exps2list (ConsExp e es) = e : exps2list es
--- this is complicated: should we change Exp or G.Term ?
erecord2term :: [LocDef] -> Err G.Term
erecord2term ds = do
ds' <- mapM locdef2fields ds
mkR $ concat ds'
where
mkR fs = do
fs' <- transF fs
return $ case fs' of
Left ts -> G.RecType ts
Right ds -> G.R ds
transF [] = return $ Left [] --- empty record always interpreted as record type
transF fs@(f:_) = case f of
(lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
_ -> mapM tryR fs >>= return . Right
tryRT f = case f of
(lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty)
_ -> Bad $ "illegal record type field" +++ show (fst f) --- manifest fields ?!
tryR f = case f of
(lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t))
_ -> Bad $ "illegal record field" +++ show (fst f)
locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))]
locdef2fields d = case d of
LDDecl ids t -> do
labs <- mapM transIdent ids
t' <- transExp t
return [(lab,(Just t',Nothing)) | lab <- labs]
LDDef ids e -> do
labs <- mapM transIdent ids
e' <- transExp e
return [(lab,(Nothing, Just e')) | lab <- labs]
LDFull ids t e -> do
labs <- mapM transIdent ids
t' <- transExp t
e' <- transExp e
return [(lab,(Just t', Just e')) | lab <- labs]
trLabel :: Label -> Err G.Label
trLabel x = case x of
-- this case is for bward compatibiity and should be removed
LPIdent (PIdent (_,'v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds
LPIdent (PIdent (_, s)) -> return $ G.LIdent s
LVar x -> return $ G.LVar $ fromInteger x
transSort :: Sort -> Err String
transSort x = case x of
_ -> return $ printTree x
transPatt :: Patt -> Err G.Patt
transPatt x = case x of
PW -> return G.wildPatt
PV id -> liftM G.PV $ transIdent id
PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
PCon id -> liftM2 G.PC (transIdent id) (return [])
PInt n -> return $ G.PInt n
PFloat n -> return $ G.PFloat n
PStr str -> return $ G.PString str
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LPIdent $ concat lss
liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps)
PTup pcs ->
liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
PQC id0 id patts ->
liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2)
PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2)
PRep p -> liftM G.PRep (transPatt p)
PNeg p -> liftM G.PNeg (transPatt p)
PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p)
transBind :: Bind -> Err Ident
transBind x = case x of
BPIdent id -> transIdent id
BWild -> return identW
transDecl :: Decl -> Err [G.Decl]
transDecl x = case x of
DDec binds exp -> do
xs <- mapM transBind binds
exp' <- transExp exp
return [(x,exp') | x <- xs]
DExp exp -> liftM (return . M.mkDecl) $ transExp exp
transCases :: [Case] -> Err [G.Case]
transCases = mapM transCase
transCase :: Case -> Err G.Case
transCase (Case p exp) = do
patt <- transPatt p
exp' <- transExp exp
return (patt,exp')
transEquation :: Equation -> Err G.Equation
transEquation x = case x of
Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp)
transAltern :: Altern -> Err (G.Term, G.Term)
transAltern x = case x of
Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp)
transParConstr :: ParConstr -> Err (Ident,G.Context)
transParConstr x = case x of
ParConstr id ddecls -> do
id' <- transIdent id
ddecls' <- mapM transDDecl ddecls
return (id',concat ddecls')
transDDecl :: DDecl -> Err [G.Decl]
transDDecl x = case x of
DDDec binds exp -> transDecl $ DDec binds exp
DDExp exp -> transDecl $ DExp exp
{- ----
-- | to deal with the old format, sort judgements in three modules, forming
-- their names from a given string, e.g. file name or overriding user-given string
transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar
transOldGrammar opts name0 x = case x of
OldGr includes topdefs -> do --- includes must be collected separately
let moddefs = sortTopDefs topdefs
g1 <- transGrammar $ Gr moddefs
removeLiT g1 --- needed for bw compatibility with an obsolete feature
where
sortTopDefs ds = [mkAbs a,mkRes ops r,mkCnc ops c] ++ map mkPack ps
where
ops = map fst ps
(a,r,c,ps) = foldr srt ([],[],[],[]) ds
srt d (a,r,c,ps) = case d of
DefCat catdefs -> (d:a,r,c,ps)
DefFun fundefs -> (d:a,r,c,ps)
DefFunData fundefs -> (d:a,r,c,ps)
DefDef defs -> (d:a,r,c,ps)
DefData pardefs -> (d:a,r,c,ps)
DefPar pardefs -> (a,d:r,c,ps)
DefOper defs -> (a,d:r,c,ps)
DefLintype defs -> (a,d:r,c,ps)
DefLincat defs -> (a,r,d:c,ps)
DefLindef defs -> (a,r,d:c,ps)
DefLin defs -> (a,r,d:c,ps)
DefPattern defs -> (a,r,d:c,ps)
DefFlag defs -> (a,r,d:c,ps) --- a guess
DefPrintCat printdefs -> (a,r,d:c,ps)
DefPrintFun printdefs -> (a,r,d:c,ps)
DefPrintOld printdefs -> (a,r,d:c,ps)
DefPackage m ds -> (a,r,c,(m,ds):ps)
_ -> (a,r,c,ps)
mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a))
mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r))
where ops = map OName ps
mkCnc ps r = MModule q (MTConcrete cncName absName)
(MBody ne (OpenIn (map OName (resName:ps))) (topDefs r))
mkPack (m, ds) = MModule q (MTResource m) (MBody ne (OpenIn []) (topDefs ds))
topDefs t = t
ne = NoExt
q = CMCompl
name = maybe name0 (++ ".gf") $ getOptVal opts useName
absName = identC $ maybe topic id $ getOptVal opts useAbsName
resName = identC $ maybe ("Res" ++ lang) id $ getOptVal opts useResName
cncName = identC $ maybe lang id $ getOptVal opts useCncName
(beg,rest) = span (/='.') name
(topic,lang) = case rest of -- to avoid overwriting old files
".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".cf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg)
[] -> ("Abs" ++ beg,"Cnc" ++ beg)
_:s -> (beg, takeWhile (/='.') s)
transInclude :: Include -> Err [FilePath]
transInclude x = case x of
NoIncl -> return []
Incl filenames -> return $ map trans filenames
where
trans f = case f of
FString s -> s
FIdent (IC s) -> modif s
FSlash filename -> '/' : trans filename
FDot filename -> '.' : trans filename
FMinus filename -> '-' : trans filename
FAddId (IC s) filename -> modif s ++ trans filename
modif s = let s' = init s ++ [toLower (last s)] in
if elem s' newReservedWords then s' else s
--- unsafe hack ; cf. GetGrammar.oldLexer
-}
newReservedWords :: [String]
newReservedWords =
words $ "abstract concrete interface incomplete " ++
"instance out open resource reuse transfer union with where"
termInPattern :: G.Term -> G.Term
termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
toP t = case t of
G.Vr x -> G.P t s
_ -> M.composSafeOp toP t
s = G.LIdent "s"
(xx,body) = abss [] t
abss xs t = case t of
G.Abs x b -> abss (x:xs) b
_ -> (reverse xs,t)
mkListId,mkConsId,mkBaseId :: PIdent -> PIdent
mkListId = prefixId "List"
mkConsId = prefixId "Cons"
mkBaseId = prefixId "Base"
prefixId :: String -> PIdent -> PIdent
prefixId pref (PIdent (p,id)) = PIdent (p, pref ++ id)