mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-30 23:02:50 -06:00
Working with interfaces and incomplete modules.
This commit is contained in:
aarne
@@ -5,7 +5,6 @@ import Ident --H
|
||||
-- Haskell module generated by the BNF converter, except --H
|
||||
|
||||
-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
|
||||
|
||||
newtype LString = LString String deriving (Eq,Ord,Show)
|
||||
data Grammar =
|
||||
Gr [ModDef]
|
||||
@@ -13,17 +12,7 @@ data Grammar =
|
||||
|
||||
data ModDef =
|
||||
MMain Ident Ident [ConcSpec]
|
||||
| MAbstract Ident Extend Opens [TopDef]
|
||||
| MResource Ident Extend Opens [TopDef]
|
||||
| MResourceInt Ident Extend Opens [TopDef]
|
||||
| MResourceImp Ident Ident Opens [TopDef]
|
||||
| MConcrete Ident Ident Extend Opens [TopDef]
|
||||
| MConcreteInt Ident Ident Extend Opens [TopDef]
|
||||
| MConcreteImp Open Ident Ident
|
||||
| MTransfer Ident Open Open Extend Opens [TopDef]
|
||||
| MReuseAbs Ident Ident
|
||||
| MReuseCnc Ident Ident
|
||||
| MReuseAll Ident Extend Ident
|
||||
| MModule ComplMod ModType ModBody
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ConcSpec =
|
||||
@@ -39,6 +28,21 @@ data Transfer =
|
||||
| TransferOut Open
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ModType =
|
||||
MTAbstract Ident
|
||||
| MTResource Ident
|
||||
| MTInterface Ident
|
||||
| MTConcrete Ident Ident
|
||||
| MTInstance Ident Ident
|
||||
| MTTransfer Ident Open Open
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ModBody =
|
||||
MBody Extend Opens [TopDef]
|
||||
| MWith Ident [Open]
|
||||
| MReuse Ident
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Extend =
|
||||
Ext Ident
|
||||
| NoExt
|
||||
@@ -51,7 +55,19 @@ data Opens =
|
||||
|
||||
data Open =
|
||||
OName Ident
|
||||
| OQual Ident Ident
|
||||
| OQualQO QualOpen Ident
|
||||
| OQual QualOpen Ident Ident
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ComplMod =
|
||||
CMCompl
|
||||
| CMIncompl
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data QualOpen =
|
||||
QOCompl
|
||||
| QOIncompl
|
||||
| QOInterface
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Def =
|
||||
|
||||
@@ -1,141 +0,0 @@
|
||||
module CompileM where
|
||||
|
||||
import Grammar
|
||||
import Ident
|
||||
import Option
|
||||
import PrGrammar
|
||||
import Update
|
||||
import Lookup
|
||||
import Modules
|
||||
---import Rename
|
||||
|
||||
import Operations
|
||||
import UseIO
|
||||
|
||||
import Monad
|
||||
|
||||
compileMGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
|
||||
compileMGrammar opts sgr = do
|
||||
|
||||
ioeErr $ checkUniqueModuleNames sgr
|
||||
|
||||
deps <- ioeErr $ moduleDeps sgr
|
||||
|
||||
deplist <- either return
|
||||
(\ms -> ioeBad $ "circular modules" +++ unwords (map show ms)) $
|
||||
topoTest deps
|
||||
|
||||
let deps' = closureDeps deps
|
||||
|
||||
foldM (compileModule opts deps' sgr) emptyMGrammar deplist
|
||||
|
||||
checkUniqueModuleNames :: MGrammar i f a r c -> Err ()
|
||||
checkUniqueModuleNames gr = do
|
||||
let ms = map fst $ tree2list $ modules gr
|
||||
msg = checkUnique ms
|
||||
if null msg then return () else Bad $ unlines msg
|
||||
|
||||
-- to decide what modules immediately depend on what, and check if the
|
||||
-- dependencies are appropriate
|
||||
|
||||
moduleDeps :: MGrammar i f a c r -> Err Dependencies
|
||||
moduleDeps gr = mapM deps $ tree2list $ modules gr where
|
||||
deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
|
||||
ModAbs m -> chDep (IdentM c MTAbstract)
|
||||
(extends m) MTAbstract (opens m) MTAbstract
|
||||
ModRes m -> chDep (IdentM c MTResource)
|
||||
(extends m) MTResource (opens m) MTResource
|
||||
ModCnc m -> do
|
||||
a:ops <- case opens m of
|
||||
os@(_:_) -> return os
|
||||
_ -> Bad "no abstract indicated for concrete module"
|
||||
aty <- lookupModuleType gr a
|
||||
testErr (aty == MTAbstract) "the for-module is not an abstract syntax"
|
||||
chDep (IdentM c (MTConcrete a)) (extends m) MTResource ops MTResource
|
||||
|
||||
chDep it es ety os oty = do
|
||||
ests <- mapM (lookupModuleType gr) es
|
||||
testErr (all (==ety) ests) "inappropriate extension module type"
|
||||
osts <- mapM (lookupModuleType gr) os
|
||||
testErr (all (==oty) osts) "inappropriate open module type"
|
||||
return (it, [IdentM e ety | e <- es] ++ [IdentM o oty | o <- os])
|
||||
|
||||
type Dependencies = [(IdentM Ident,[IdentM Ident])]
|
||||
|
||||
---compileModule :: Options -> Dependencies -> SourceGrammar ->
|
||||
--- CanonGrammar -> IdentM -> IOE CanonGrammar
|
||||
compileModule opts deps sgr cgr i = do
|
||||
|
||||
let name = identM i
|
||||
|
||||
testIfCompiled deps name
|
||||
|
||||
mi <- ioeErr $ lookupModule sgr name
|
||||
|
||||
mi' <- case typeM i of
|
||||
-- previously compiled cgr used as symbol table
|
||||
MTAbstract -> compileAbstract cgr mi
|
||||
MTResource -> compileResource cgr mi
|
||||
MTConcrete a -> compileConcrete a cgr mi
|
||||
|
||||
ifIsOpt doOutput $ writeCanonFile name mi'
|
||||
|
||||
return $ addModule cgr name mi'
|
||||
|
||||
where
|
||||
|
||||
ifIsOpt o f = if (oElem o opts) then f else return ()
|
||||
doOutput = iOpt "o"
|
||||
|
||||
|
||||
testIfCompiled :: Dependencies -> Ident -> IOE Bool
|
||||
testIfCompiled _ _ = return False ----
|
||||
|
||||
---writeCanonFile :: Ident -> CanonModInfo -> IOE ()
|
||||
writeCanonFile name mi' = ioeIO $ writeFile (canonFileName name) [] ----
|
||||
|
||||
canonFileName n = n ++ ".gfc" ---- elsewhere!
|
||||
|
||||
---compileAbstract :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
|
||||
compileAbstract can (ModAbs m0) = do
|
||||
let m1 = renameMAbstract m0
|
||||
{-
|
||||
checkUnique
|
||||
typeCheck
|
||||
generateCode
|
||||
addToCanon
|
||||
-}
|
||||
ioeBad "compile abs not yet"
|
||||
|
||||
---compileResource :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
|
||||
compileResource can md = do
|
||||
{-
|
||||
checkUnique
|
||||
typeCheck
|
||||
topoSort
|
||||
compileOpers -- conservative, since more powerful than lin
|
||||
generateCode
|
||||
addToCanon
|
||||
-}
|
||||
ioeBad "compile res not yet"
|
||||
|
||||
---compileConcrete :: Ident -> CanonGrammar -> SourceModInfo -> IOE CanonModInfo
|
||||
compileConcrete ab can md = do
|
||||
{-
|
||||
checkUnique
|
||||
checkComplete ab
|
||||
typeCheck
|
||||
topoSort
|
||||
compileOpers
|
||||
optimize
|
||||
createPreservedOpers
|
||||
generateCode
|
||||
addToCanon
|
||||
-}
|
||||
ioeBad "compile cnc not yet"
|
||||
|
||||
|
||||
-- to be imported
|
||||
|
||||
closureDeps :: [(a,[a])] -> [(a,[a])]
|
||||
closureDeps ds = ds ---- fix-point iteration
|
||||
286
src/GF/Source/GF.cf
Normal file
286
src/GF/Source/GF.cf
Normal file
@@ -0,0 +1,286 @@
|
||||
-- AR 2/5/2003, 14-16 o'clock, Torino
|
||||
|
||||
entrypoints Grammar, ModDef, OldGrammar, Exp ; -- let's see if more are needed
|
||||
|
||||
comment "--" ;
|
||||
comment "{-" "-}" ;
|
||||
|
||||
-- the top-level grammar
|
||||
|
||||
Gr. Grammar ::= [ModDef] ;
|
||||
|
||||
-- semicolon after module is permitted but not obligatory
|
||||
|
||||
terminator ModDef "" ;
|
||||
_. ModDef ::= ModDef ";" ;
|
||||
|
||||
-- The $main$ multilingual grammar structure
|
||||
|
||||
MMain. ModDef ::= "grammar" Ident "=" "{" "abstract" "=" Ident ";" [ConcSpec] "}" ;
|
||||
|
||||
ConcSpec. ConcSpec ::= Ident "=" ConcExp ;
|
||||
separator ConcSpec ";" ;
|
||||
|
||||
ConcExp. ConcExp ::= Ident [Transfer] ;
|
||||
|
||||
separator Transfer "" ;
|
||||
TransferIn. Transfer ::= "(" "transfer" "in" Open ")" ;
|
||||
TransferOut. Transfer ::= "(" "transfer" "out" Open ")" ;
|
||||
|
||||
-- the individual modules
|
||||
|
||||
MModule. ModDef ::= ComplMod ModType "=" ModBody ;
|
||||
|
||||
MTAbstract. ModType ::= "abstract" Ident ;
|
||||
MTResource. ModType ::= "resource" Ident ;
|
||||
MTInterface. ModType ::= "interface" Ident ;
|
||||
MTConcrete. ModType ::= "concrete" Ident "of" Ident ;
|
||||
MTInstance. ModType ::= "instance" Ident "of" Ident ;
|
||||
MTTransfer. ModType ::= "transfer" Ident ":" Open "->" Open ;
|
||||
|
||||
MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ;
|
||||
MWith. ModBody ::= Ident "with" [Open] ;
|
||||
MReuse. ModBody ::= "reuse" Ident ;
|
||||
|
||||
separator TopDef "" ;
|
||||
|
||||
Ext. Extend ::= Ident "**" ;
|
||||
NoExt. Extend ::= ;
|
||||
|
||||
separator Open "," ;
|
||||
NoOpens. Opens ::= ;
|
||||
Opens. Opens ::= "open" [Open] "in" ;
|
||||
|
||||
OName. Open ::= Ident ;
|
||||
OQualQO. Open ::= "(" QualOpen Ident ")" ;
|
||||
OQual. Open ::= "(" QualOpen Ident "=" Ident ")" ;
|
||||
|
||||
CMCompl. ComplMod ::= ;
|
||||
CMIncompl. ComplMod ::= "incomplete" ;
|
||||
|
||||
QOCompl. QualOpen ::= ;
|
||||
QOIncompl. QualOpen ::= "incomplete" ;
|
||||
QOInterface. QualOpen ::= "interface" ;
|
||||
|
||||
-- definitions after the $oper$ keywords
|
||||
|
||||
DDecl. Def ::= [Ident] ":" Exp ;
|
||||
DDef. Def ::= [Ident] "=" Exp ;
|
||||
DPatt. Def ::= Ident [Patt] "=" Exp ; -- non-empty pattern list
|
||||
DFull. Def ::= [Ident] ":" Exp "=" Exp ;
|
||||
|
||||
-- top-level definitions
|
||||
|
||||
DefCat. TopDef ::= "cat" [CatDef] ;
|
||||
DefFun. TopDef ::= "fun" [FunDef] ;
|
||||
DefDef. TopDef ::= "def" [Def] ;
|
||||
DefData. TopDef ::= "data" [DataDef] ;
|
||||
|
||||
DefTrans. TopDef ::= "transfer" [Def] ;
|
||||
|
||||
DefPar. TopDef ::= "param" [ParDef] ;
|
||||
DefOper. TopDef ::= "oper" [Def] ;
|
||||
|
||||
DefLincat. TopDef ::= "lincat" [PrintDef] ;
|
||||
DefLindef. TopDef ::= "lindef" [Def] ;
|
||||
DefLin. TopDef ::= "lin" [Def] ;
|
||||
|
||||
DefPrintCat. TopDef ::= "printname" "cat" [PrintDef] ;
|
||||
DefPrintFun. TopDef ::= "printname" "fun" [PrintDef] ;
|
||||
DefFlag. TopDef ::= "flags" [FlagDef] ;
|
||||
|
||||
CatDef. CatDef ::= Ident [DDecl] ;
|
||||
FunDef. FunDef ::= [Ident] ":" Exp ;
|
||||
|
||||
DataDef. DataDef ::= Ident "=" [DataConstr] ;
|
||||
DataId. DataConstr ::= Ident ;
|
||||
DataQId. DataConstr ::= Ident "." Ident ;
|
||||
separator DataConstr "|" ;
|
||||
|
||||
|
||||
ParDef. ParDef ::= Ident "=" [ParConstr] ;
|
||||
ParDefIndir. ParDef ::= Ident "=" "(" "in" Ident ")" ;
|
||||
ParDefAbs. ParDef ::= Ident ;
|
||||
|
||||
ParConstr. ParConstr ::= Ident [DDecl] ;
|
||||
|
||||
PrintDef. PrintDef ::= [Ident] "=" Exp ;
|
||||
|
||||
FlagDef. FlagDef ::= Ident "=" Ident ;
|
||||
|
||||
terminator nonempty Def ";" ;
|
||||
terminator nonempty CatDef ";" ;
|
||||
terminator nonempty FunDef ";" ;
|
||||
terminator nonempty DataDef ";" ;
|
||||
terminator nonempty ParDef ";" ;
|
||||
|
||||
terminator nonempty PrintDef ";" ;
|
||||
terminator nonempty FlagDef ";" ;
|
||||
|
||||
separator ParConstr "|" ;
|
||||
|
||||
separator nonempty Ident "," ;
|
||||
|
||||
-- definitions in records and $let$ expressions
|
||||
|
||||
LDDecl. LocDef ::= [Ident] ":" Exp ;
|
||||
LDDef. LocDef ::= [Ident] "=" Exp ;
|
||||
LDFull. LocDef ::= [Ident] ":" Exp "=" Exp ;
|
||||
|
||||
separator LocDef ";" ;
|
||||
|
||||
-- terms and types
|
||||
|
||||
EIdent. Exp4 ::= Ident ;
|
||||
EConstr. Exp4 ::= "{" Ident "}" ;
|
||||
ECons. Exp4 ::= "[" Ident "]" ;
|
||||
ESort. Exp4 ::= Sort ;
|
||||
EString. Exp4 ::= String ;
|
||||
EInt. Exp4 ::= Integer ;
|
||||
EMeta. Exp4 ::= "?" ;
|
||||
EEmpty. Exp4 ::= "[" "]" ;
|
||||
EStrings. Exp4 ::= "[" String "]" ;
|
||||
ERecord. Exp4 ::= "{" [LocDef] "}" ; -- !
|
||||
ETuple. Exp4 ::= "<" [TupleComp] ">" ; --- needed for separator ","
|
||||
EIndir. Exp4 ::= "(" "in" Ident ")" ; -- indirection, used in judgements
|
||||
ETyped. Exp4 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations
|
||||
|
||||
EProj. Exp3 ::= Exp3 "." Label ;
|
||||
EQConstr. Exp3 ::= "{" Ident "." Ident "}" ; -- qualified constructor
|
||||
EQCons. Exp3 ::= "[" Ident "." Ident "]" ; -- qualified constant
|
||||
|
||||
EApp. Exp2 ::= Exp2 Exp3 ;
|
||||
ETable. Exp2 ::= "table" "{" [Case] "}" ;
|
||||
ETTable. Exp2 ::= "table" Exp4 "{" [Case] "}" ;
|
||||
ECase. Exp2 ::= "case" Exp "of" "{" [Case] "}" ;
|
||||
EVariants. Exp2 ::= "variants" "{" [Exp] "}" ;
|
||||
EPre. Exp2 ::= "pre" "{" Exp ";" [Altern] "}" ;
|
||||
EStrs. Exp2 ::= "strs" "{" [Exp] "}" ;
|
||||
EConAt. Exp2 ::= Ident "@" Exp4 ;
|
||||
|
||||
ESelect. Exp1 ::= Exp1 "!" Exp2 ;
|
||||
ETupTyp. Exp1 ::= Exp1 "*" Exp2 ;
|
||||
EExtend. Exp1 ::= Exp1 "**" Exp2 ;
|
||||
|
||||
EAbstr. Exp ::= "\\" [Bind] "->" Exp ;
|
||||
ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ;
|
||||
EProd. Exp ::= Decl "->" Exp ;
|
||||
ETType. Exp ::= Exp1 "=>" Exp ; -- these are thus right associative
|
||||
EConcat. Exp ::= Exp1 "++" Exp ;
|
||||
EGlue. Exp ::= Exp1 "+" Exp ;
|
||||
ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ;
|
||||
EEqs. Exp ::= "fn" "{" [Equation] "}" ;
|
||||
|
||||
coercions Exp 4 ;
|
||||
|
||||
separator Exp ";" ; -- in variants
|
||||
|
||||
-- patterns
|
||||
|
||||
PW. Patt1 ::= "_" ;
|
||||
PV. Patt1 ::= Ident ;
|
||||
PCon. Patt1 ::= "{" Ident "}" ;
|
||||
PQ. Patt1 ::= Ident "." Ident ;
|
||||
PInt. Patt1 ::= Integer ;
|
||||
PStr. Patt1 ::= String ;
|
||||
PR. Patt1 ::= "{" [PattAss] "}" ;
|
||||
PTup. Patt1 ::= "<" [PattTupleComp] ">" ;
|
||||
PC. Patt ::= Ident [Patt] ;
|
||||
PQC. Patt ::= Ident "." Ident [Patt] ;
|
||||
|
||||
coercions Patt 1 ;
|
||||
|
||||
PA. PattAss ::= [Ident] "=" Patt ;
|
||||
|
||||
-- labels
|
||||
|
||||
LIdent. Label ::= Ident ;
|
||||
LVar. Label ::= "$" Integer ;
|
||||
|
||||
-- basic types
|
||||
|
||||
rules Sort ::= "Type" | "PType" | "Tok" | "Str" | "Strs" ;
|
||||
|
||||
separator PattAss ";" ;
|
||||
|
||||
AltP. PattAlt ::= Patt ;
|
||||
|
||||
-- this is explicit to force higher precedence level on rhs
|
||||
(:[]). [Patt] ::= Patt1 ;
|
||||
(:). [Patt] ::= Patt1 [Patt] ;
|
||||
|
||||
separator nonempty PattAlt "|" ;
|
||||
|
||||
-- binds in lambdas and lin rules
|
||||
|
||||
BIdent. Bind ::= Ident ;
|
||||
BWild. Bind ::= "_" ;
|
||||
|
||||
separator Bind "," ;
|
||||
|
||||
|
||||
-- declarations in function types
|
||||
|
||||
DDec. Decl ::= "(" [Bind] ":" Exp ")" ;
|
||||
DExp. Decl ::= Exp2 ; -- can thus be an application
|
||||
|
||||
-- tuple component (term or pattern)
|
||||
|
||||
TComp. TupleComp ::= Exp ;
|
||||
PTComp. PattTupleComp ::= Patt ;
|
||||
|
||||
separator TupleComp "," ;
|
||||
separator PattTupleComp "," ;
|
||||
|
||||
-- case branches
|
||||
|
||||
Case. Case ::= [PattAlt] "=>" 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 ::= Exp4 ; -- 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 ";" ;
|
||||
|
||||
FIdent. FileName ::= Ident ;
|
||||
FSlash. FileName ::= "/" FileName ;
|
||||
FDot. FileName ::= "." FileName ;
|
||||
FMinus. FileName ::= "-" FileName ;
|
||||
FAddId. FileName ::= Ident FileName ;
|
||||
|
||||
token LString '\'' (char - '\'')* '\'' ;
|
||||
ELString. Exp4 ::= LString ;
|
||||
ELin. Exp2 ::= "Lin" Ident ;
|
||||
|
||||
DefPrintOld. TopDef ::= "printname" [PrintDef] ;
|
||||
DefLintype. TopDef ::= "lintype" [Def] ;
|
||||
DefPattern. TopDef ::= "pattern" [Def] ;
|
||||
@@ -15,16 +15,20 @@ trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
|
||||
|
||||
trModule :: (Ident,SourceModInfo) -> P.ModDef
|
||||
trModule (i,mo) = case mo of
|
||||
ModMod m -> mkModule i' (trExtend (extends m)) (mkOpens (map trOpen (opens m)))
|
||||
(mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++
|
||||
(map trFlag (flags m))))
|
||||
where
|
||||
i' = tri i
|
||||
mkModule m = case typeOfModule mo of
|
||||
MTResource -> P.MResource m
|
||||
MTAbstract -> P.MAbstract m
|
||||
MTConcrete a -> P.MConcrete m (tri a)
|
||||
MTTransfer a b -> P.MTransfer m (trOpen a) (trOpen b)
|
||||
ModMod m -> P.MModule compl typ body where
|
||||
compl = P.CMCompl -- always complete module
|
||||
i' = tri i
|
||||
typ = case typeOfModule mo of
|
||||
MTResource -> P.MTResource i'
|
||||
MTAbstract -> P.MTAbstract i'
|
||||
MTConcrete a -> P.MTConcrete i' (tri a)
|
||||
MTTransfer a b -> P.MTTransfer i' (trOpen a) (trOpen b)
|
||||
MTInstance a -> P.MTInstance i' (tri a)
|
||||
MTInterface -> P.MTInterface i'
|
||||
body = P.MBody
|
||||
(trExtend (extends m))
|
||||
(mkOpens (map trOpen (opens m)))
|
||||
(mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m)))
|
||||
|
||||
trExtend :: Maybe Ident -> P.Extend
|
||||
trExtend i = maybe P.NoExt (P.Ext . tri) i
|
||||
@@ -34,8 +38,15 @@ forName (MTConcrete a) = tri a
|
||||
|
||||
trOpen :: OpenSpec Ident -> P.Open
|
||||
trOpen o = case o of
|
||||
OSimple i -> P.OName (tri i)
|
||||
OQualif i j -> P.OQual (tri i) (tri j)
|
||||
OSimple OQNormal i -> P.OQualQO P.QOCompl (tri i)
|
||||
OSimple q i -> P.OQualQO (trQualOpen q) (tri i)
|
||||
OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j)
|
||||
|
||||
trQualOpen q = case q of
|
||||
OQNormal -> P.QOCompl
|
||||
OQIncomplete -> P.QOIncompl
|
||||
OQInterface -> P.QOInterface
|
||||
|
||||
|
||||
mkOpens ds = if null ds then P.NoOpens else P.Opens ds
|
||||
mkTopDefs ds = ds
|
||||
|
||||
@@ -55,7 +55,7 @@ tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
|
||||
eitherResIdent :: (String -> Tok) -> String -> Tok
|
||||
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
|
||||
isResWord s = isInTree s $
|
||||
B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N))))
|
||||
B "interface" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "grammar" (B "fn" (B "flags" (B "def" N N) N) (B "fun" N N)) (B "incomplete" (B "include" (B "in" N N) N) (B "instance" N N)))) (B "pattern" (B "of" (B "lincat" (B "lin" (B "let" N N) N) (B "lintype" (B "lindef" N N) N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "variants" (B "transfer" (B "table" N N) N) (B "with" N N))))
|
||||
|
||||
data BTree = N | B String BTree BTree deriving (Show)
|
||||
|
||||
@@ -114,7 +114,7 @@ lx__14_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[]))
|
||||
lx__15_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
|
||||
lx__15_0 = (False,[],15,(('\'','\''),[('\'',16)]))
|
||||
lx__16_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
|
||||
lx__16_0 = (True,[(4,"mk_LString",[],Nothing,Nothing)],15,(('\'','\''),[('\'',16)]))
|
||||
lx__16_0 = (True,[(4,"mk_LString",[],Nothing,Nothing)],-1,(('0','0'),[]))
|
||||
lx__17_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
|
||||
lx__17_0 = (True,[(5,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',17),('0',17),('1',17),('2',17),('3',17),('4',17),('5',17),('6',17),('7',17),('8',17),('9',17),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('_',17),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)]))
|
||||
lx__18_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
|
||||
|
||||
@@ -7,6 +7,7 @@ import Ident --H
|
||||
import Char
|
||||
|
||||
-- the top-level printing method
|
||||
|
||||
printTree :: Print a => a -> String
|
||||
printTree = render . prt 0
|
||||
|
||||
@@ -88,17 +89,7 @@ instance Print Grammar where
|
||||
instance Print ModDef where
|
||||
prt i e = case e of
|
||||
MMain id0 id concspecs -> prPrec i 0 (concat [["grammar"] , prt 0 id0 , ["="] , ["{"] , ["abstract"] , ["="] , prt 0 id , [";"] , prt 0 concspecs , ["}"]])
|
||||
MAbstract id extend opens topdefs -> prPrec i 0 (concat [["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MResource id extend opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MResourceInt id extend opens topdefs -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MResourceImp id0 id opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MConcrete id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MConcreteInt id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , ["abstract"] , ["of"] , prt 0 id0 , ["in"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MConcreteImp open id0 id -> prPrec i 0 (concat [["concrete"] , ["of"] , prt 0 open , ["="] , prt 0 id0 , ["**"] , prt 0 id])
|
||||
MTransfer id open0 open extend opens topdefs -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MReuseAbs id0 id -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id])
|
||||
MReuseCnc id0 id -> prPrec i 0 (concat [["resource"] , ["concrete"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id])
|
||||
MReuseAll id0 extend id -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["="] , prt 0 extend , ["reuse"] , prt 0 id])
|
||||
MModule complmod modtype modbody -> prPrec i 0 (concat [prt 0 complmod , prt 0 modtype , ["="] , prt 0 modbody])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
@@ -127,6 +118,23 @@ instance Print Transfer where
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print ModType where
|
||||
prt i e = case e of
|
||||
MTAbstract id -> prPrec i 0 (concat [["abstract"] , prt 0 id])
|
||||
MTResource id -> prPrec i 0 (concat [["resource"] , prt 0 id])
|
||||
MTInterface id -> prPrec i 0 (concat [["interface"] , prt 0 id])
|
||||
MTConcrete id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id])
|
||||
MTInstance id0 id -> prPrec i 0 (concat [["instance"] , prt 0 id0 , ["of"] , prt 0 id])
|
||||
MTTransfer id open0 open -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open])
|
||||
|
||||
|
||||
instance Print ModBody where
|
||||
prt i e = case e of
|
||||
MBody extend opens topdefs -> prPrec i 0 (concat [prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
|
||||
MWith id opens -> prPrec i 0 (concat [prt 0 id , ["with"] , prt 0 opens])
|
||||
MReuse id -> prPrec i 0 (concat [["reuse"] , prt 0 id])
|
||||
|
||||
|
||||
instance Print Extend where
|
||||
prt i e = case e of
|
||||
Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]])
|
||||
@@ -142,13 +150,27 @@ instance Print Opens where
|
||||
instance Print Open where
|
||||
prt i e = case e of
|
||||
OName id -> prPrec i 0 (concat [prt 0 id])
|
||||
OQual id0 id -> prPrec i 0 (concat [["("] , prt 0 id0 , ["="] , prt 0 id , [")"]])
|
||||
OQualQO qualopen id -> prPrec i 0 (concat [["("] , prt 0 qualopen , prt 0 id , [")"]])
|
||||
OQual qualopen id0 id -> prPrec i 0 (concat [["("] , prt 0 qualopen , prt 0 id0 , ["="] , prt 0 id , [")"]])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
|
||||
|
||||
instance Print ComplMod where
|
||||
prt i e = case e of
|
||||
CMCompl -> prPrec i 0 (concat [])
|
||||
CMIncompl -> prPrec i 0 (concat [["incomplete"]])
|
||||
|
||||
|
||||
instance Print QualOpen where
|
||||
prt i e = case e of
|
||||
QOCompl -> prPrec i 0 (concat [])
|
||||
QOIncompl -> prPrec i 0 (concat [["incomplete"]])
|
||||
QOInterface -> prPrec i 0 (concat [["interface"]])
|
||||
|
||||
|
||||
instance Print Def where
|
||||
prt i e = case e of
|
||||
DDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
|
||||
|
||||
@@ -27,17 +27,7 @@ transGrammar x = case x of
|
||||
transModDef :: ModDef -> Result
|
||||
transModDef x = case x of
|
||||
MMain id0 id concspecs -> failure x
|
||||
MAbstract id extend opens topdefs -> failure x
|
||||
MResource id extend opens topdefs -> failure x
|
||||
MResourceInt id extend opens topdefs -> failure x
|
||||
MResourceImp id0 id opens topdefs -> failure x
|
||||
MConcrete id0 id extend opens topdefs -> failure x
|
||||
MConcreteInt id0 id extend opens topdefs -> failure x
|
||||
MConcreteImp open id0 id -> failure x
|
||||
MTransfer id open0 open extend opens topdefs -> failure x
|
||||
MReuseAbs id0 id -> failure x
|
||||
MReuseCnc id0 id -> failure x
|
||||
MReuseAll id0 extend id -> failure x
|
||||
MModule complmod modtype modbody -> failure x
|
||||
|
||||
|
||||
transConcSpec :: ConcSpec -> Result
|
||||
@@ -56,6 +46,23 @@ transTransfer x = case x of
|
||||
TransferOut open -> failure x
|
||||
|
||||
|
||||
transModType :: ModType -> Result
|
||||
transModType x = case x of
|
||||
MTAbstract id -> failure x
|
||||
MTResource id -> failure x
|
||||
MTInterface id -> failure x
|
||||
MTConcrete id0 id -> failure x
|
||||
MTInstance id0 id -> failure x
|
||||
MTTransfer id open0 open -> failure x
|
||||
|
||||
|
||||
transModBody :: ModBody -> Result
|
||||
transModBody x = case x of
|
||||
MBody extend opens topdefs -> failure x
|
||||
MWith id opens -> failure x
|
||||
MReuse id -> failure x
|
||||
|
||||
|
||||
transExtend :: Extend -> Result
|
||||
transExtend x = case x of
|
||||
Ext id -> failure x
|
||||
@@ -71,7 +78,21 @@ transOpens x = case x of
|
||||
transOpen :: Open -> Result
|
||||
transOpen x = case x of
|
||||
OName id -> failure x
|
||||
OQual id0 id -> failure x
|
||||
OQualQO qualopen id -> failure x
|
||||
OQual qualopen id0 id -> failure x
|
||||
|
||||
|
||||
transComplMod :: ComplMod -> Result
|
||||
transComplMod x = case x of
|
||||
CMCompl -> failure x
|
||||
CMIncompl -> failure x
|
||||
|
||||
|
||||
transQualOpen :: QualOpen -> Result
|
||||
transQualOpen x = case x of
|
||||
QOCompl -> failure x
|
||||
QOIncompl -> failure x
|
||||
QOInterface -> failure x
|
||||
|
||||
|
||||
transDef :: Def -> Result
|
||||
|
||||
@@ -35,56 +35,63 @@ transGrammar x = case x of
|
||||
|
||||
transModDef :: ModDef -> Err (Ident, G.SourceModInfo)
|
||||
transModDef x = case x of
|
||||
|
||||
MMain id0 id concspecs -> do
|
||||
id0' <- transIdent id0
|
||||
id' <- transIdent id
|
||||
concspecs' <- mapM transConcSpec concspecs
|
||||
return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs'))
|
||||
MAbstract id extends opens defs -> do
|
||||
id' <- transIdent id
|
||||
extends' <- transExtend extends
|
||||
opens' <- transOpens opens
|
||||
defs0 <- mapM transAbsDef $ getTopDefs defs
|
||||
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
|
||||
flags <- return [f | Right fs <- defs0, f <- fs]
|
||||
return $ (id', GM.ModMod (GM.Module GM.MTAbstract flags extends' opens' defs'))
|
||||
MResource id extends opens defs -> do
|
||||
id' <- transIdent id
|
||||
extends' <- transExtend extends
|
||||
opens' <- transOpens opens
|
||||
defs0 <- mapM transResDef $ getTopDefs defs
|
||||
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
|
||||
flags <- return [f | Right fs <- defs0, f <- fs]
|
||||
return $ (id', GM.ModMod (GM.Module GM.MTResource flags extends' opens' defs'))
|
||||
MConcrete id open extends opens defs -> do
|
||||
id' <- transIdent id
|
||||
open' <- transIdent open
|
||||
extends' <- transExtend extends
|
||||
opens' <- transOpens opens
|
||||
defs0 <- mapM transCncDef $ getTopDefs defs
|
||||
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
|
||||
flags <- return [f | Right fs <- defs0, f <- fs]
|
||||
return $ (id',
|
||||
GM.ModMod (GM.Module (GM.MTConcrete open') flags extends' opens' defs'))
|
||||
MTransfer id open0 open extends opens defs -> do
|
||||
id' <- transIdent id
|
||||
open0' <- transOpen open0
|
||||
open' <- transOpen open
|
||||
extends' <- transExtend extends
|
||||
opens' <- transOpens opens
|
||||
defs0 <- mapM transAbsDef $ getTopDefs defs
|
||||
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
|
||||
flags <- return [f | Right fs <- defs0, f <- fs]
|
||||
return $ (id',
|
||||
GM.ModMod (GM.Module (GM.MTTransfer open0' open') flags extends' opens' defs'))
|
||||
|
||||
MReuseAbs id0 id -> failure x
|
||||
MReuseCnc id0 id -> failure x
|
||||
MReuseAll r e c -> do
|
||||
r' <- transIdent r
|
||||
e' <- transExtend e
|
||||
c' <- transIdent c
|
||||
return $ (r', GM.ModMod (GM.Module (GM.MTReuse c') [] e' [] NT))
|
||||
MModule compl mtyp body -> do
|
||||
|
||||
let mstat' = transComplMod compl
|
||||
|
||||
(trDef, mtyp', id') <- case mtyp of
|
||||
MTAbstract id -> do
|
||||
id' <- transIdent id
|
||||
return (transAbsDef, GM.MTAbstract, id')
|
||||
MTResource id -> case body of
|
||||
MReuse c -> do
|
||||
id' <- transIdent id
|
||||
c' <- transIdent c
|
||||
return (transResDef, GM.MTReuse c', id')
|
||||
_ -> do
|
||||
id' <- transIdent id
|
||||
return (transResDef, GM.MTResource, id')
|
||||
MTConcrete id open -> do
|
||||
id' <- transIdent id
|
||||
open' <- transIdent open
|
||||
return (transCncDef, GM.MTConcrete open', id')
|
||||
MTTransfer id a b -> do
|
||||
id' <- transIdent id
|
||||
a' <- transOpen a
|
||||
b' <- transOpen a
|
||||
return (transAbsDef, GM.MTTransfer a' b', id')
|
||||
MTInterface id -> do
|
||||
id' <- transIdent id
|
||||
return (transResDef, GM.MTInterface, id')
|
||||
MTInstance id open -> do
|
||||
id' <- transIdent id
|
||||
open' <- transIdent open
|
||||
return (transResDef, GM.MTInstance open', id')
|
||||
|
||||
(extends', opens', defs',flags') <- case body of
|
||||
MBody extends opens defs -> do
|
||||
extends' <- transExtend extends
|
||||
opens' <- transOpens opens
|
||||
defs0 <- mapM trDef $ getTopDefs defs
|
||||
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
|
||||
flags' <- return [f | Right fs <- defs0, f <- fs]
|
||||
return $ (extends', opens', defs',flags')
|
||||
MReuse _ ->
|
||||
return (Nothing,[],NT,[])
|
||||
|
||||
return $ (id', GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
|
||||
|
||||
transComplMod :: ComplMod -> GM.ModuleStatus
|
||||
transComplMod x = case x of
|
||||
CMCompl -> GM.MSComplete
|
||||
CMIncompl -> GM.MSIncomplete
|
||||
|
||||
getTopDefs :: [TopDef] -> [TopDef]
|
||||
getTopDefs x = x
|
||||
@@ -130,8 +137,15 @@ transOpens x = case x of
|
||||
|
||||
transOpen :: Open -> Err (GM.OpenSpec Ident)
|
||||
transOpen x = case x of
|
||||
OName id -> liftM GM.OSimple $ transIdent id
|
||||
OQual id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
|
||||
OName id -> liftM (GM.OSimple GM.OQNormal) $ transIdent id
|
||||
OQualQO q id -> liftM2 GM.OSimple (transQualOpen q) (transIdent id)
|
||||
OQual q id m -> liftM3 GM.OQualif (transQualOpen q) (transIdent id) (transIdent m)
|
||||
|
||||
transQualOpen :: QualOpen -> Err GM.OpenQualif
|
||||
transQualOpen x = case x of
|
||||
QOCompl -> return GM.OQNormal
|
||||
QOInterface -> return GM.OQInterface
|
||||
QOIncompl -> return GM.OQIncomplete
|
||||
|
||||
transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
|
||||
transAbsDef x = case x of
|
||||
@@ -489,10 +503,13 @@ transOldGrammar x name = case x of
|
||||
DefPrintCat printdefs -> (a,r,d:c)
|
||||
DefPrintFun printdefs -> (a,r,d:c)
|
||||
DefPrintOld printdefs -> (a,r,d:c)
|
||||
mkAbs a = MAbstract absName NoExt (Opens []) $ topDefs a
|
||||
mkRes r = MResource resName NoExt (Opens []) $ topDefs r
|
||||
mkCnc r = MConcrete cncName absName NoExt (Opens [OName resName]) $ topDefs r
|
||||
mkAbs a = MModule q (MTAbstract absName) (MBody ne (Opens []) (topDefs a))
|
||||
mkRes r = MModule q (MTResource resName) (MBody ne (Opens []) (topDefs r))
|
||||
mkCnc r = MModule q (MTConcrete cncName absName)
|
||||
(MBody ne (Opens [OName resName]) (topDefs r))
|
||||
topDefs t = t
|
||||
ne = NoExt
|
||||
q = CMCompl
|
||||
|
||||
absName = identC topic
|
||||
resName = identC ("Res" ++ lang)
|
||||
|
||||
Reference in New Issue
Block a user