mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-06 09:42:50 -06:00
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
274
src-3.0/GF/Devel/Compile/AbsGF.hs
Normal file
274
src-3.0/GF/Devel/Compile/AbsGF.hs
Normal file
@@ -0,0 +1,274 @@
|
||||
module GF.Devel.Compile.AbsGF where
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show)
|
||||
newtype LString = LString String deriving (Eq,Ord,Show)
|
||||
data Grammar =
|
||||
Gr [ModDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ModDef =
|
||||
MModule ComplMod ModType ModBody
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ModType =
|
||||
MAbstract PIdent
|
||||
| MResource PIdent
|
||||
| MGrammar PIdent
|
||||
| MInterface PIdent
|
||||
| MConcrete PIdent PIdent
|
||||
| MInstance PIdent PIdent
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ModBody =
|
||||
MBody Extend Opens [TopDef]
|
||||
| MNoBody [Included]
|
||||
| MWith Included [Open]
|
||||
| MWithBody Included [Open] Opens [TopDef]
|
||||
| MWithE [Included] Included [Open]
|
||||
| MWithEBody [Included] Included [Open] Opens [TopDef]
|
||||
| MReuse PIdent
|
||||
| MUnion [Included]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Extend =
|
||||
Ext [Included]
|
||||
| NoExt
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Opens =
|
||||
NoOpens
|
||||
| OpenIn [Open]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Open =
|
||||
OName PIdent
|
||||
| OQual PIdent PIdent
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ComplMod =
|
||||
CMCompl
|
||||
| CMIncompl
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Included =
|
||||
IAll PIdent
|
||||
| ISome PIdent [PIdent]
|
||||
| IMinus PIdent [PIdent]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data TopDef =
|
||||
DefCat [CatDef]
|
||||
| DefFun [FunDef]
|
||||
| DefFunData [FunDef]
|
||||
| DefDef [Def]
|
||||
| DefData [DataDef]
|
||||
| DefPar [ParDef]
|
||||
| DefOper [Def]
|
||||
| DefLincat [Def]
|
||||
| DefLindef [Def]
|
||||
| DefLin [Def]
|
||||
| DefPrintCat [Def]
|
||||
| DefPrintFun [Def]
|
||||
| DefFlag [Def]
|
||||
| DefPrintOld [Def]
|
||||
| DefLintype [Def]
|
||||
| DefPattern [Def]
|
||||
| DefPackage PIdent [TopDef]
|
||||
| DefVars [Def]
|
||||
| DefTokenizer PIdent
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Def =
|
||||
DDecl [Name] Exp
|
||||
| DDef [Name] Exp
|
||||
| DPatt Name [Patt] Exp
|
||||
| DFull [Name] Exp Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data FunDef =
|
||||
FDecl [Name] Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data CatDef =
|
||||
SimpleCatDef PIdent [DDecl]
|
||||
| ListCatDef PIdent [DDecl]
|
||||
| ListSizeCatDef PIdent [DDecl] Integer
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data DataDef =
|
||||
DataDef Name [DataConstr]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data DataConstr =
|
||||
DataId PIdent
|
||||
| DataQId PIdent PIdent
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ParDef =
|
||||
ParDefDir PIdent [ParConstr]
|
||||
| ParDefAbs PIdent
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data ParConstr =
|
||||
ParConstr PIdent [DDecl]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Name =
|
||||
PIdentName PIdent
|
||||
| ListName PIdent
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LocDef =
|
||||
LDDecl [PIdent] Exp
|
||||
| LDDef [PIdent] Exp
|
||||
| LDFull [PIdent] Exp Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Exp =
|
||||
EPIdent PIdent
|
||||
| EConstr PIdent
|
||||
| ECons PIdent
|
||||
| ESort Sort
|
||||
| EString String
|
||||
| EInt Integer
|
||||
| EFloat Double
|
||||
| EMeta
|
||||
| EEmpty
|
||||
| EData
|
||||
| EList PIdent Exps
|
||||
| EStrings String
|
||||
| ERecord [LocDef]
|
||||
| ETuple [TupleComp]
|
||||
| EIndir PIdent
|
||||
| ETyped Exp Exp
|
||||
| EProj Exp Label
|
||||
| EQConstr PIdent PIdent
|
||||
| EQCons PIdent PIdent
|
||||
| EApp Exp Exp
|
||||
| ETable [Case]
|
||||
| ETTable Exp [Case]
|
||||
| EVTable Exp [Exp]
|
||||
| ECase Exp [Case]
|
||||
| EVariants [Exp]
|
||||
| EPre Exp [Altern]
|
||||
| EStrs [Exp]
|
||||
| EPatt Patt
|
||||
| EPattType Exp
|
||||
| ESelect Exp Exp
|
||||
| ETupTyp Exp Exp
|
||||
| EExtend Exp Exp
|
||||
| EGlue Exp Exp
|
||||
| EConcat Exp Exp
|
||||
| EAbstr [Bind] Exp
|
||||
| ECTable [Bind] Exp
|
||||
| EProd Decl Exp
|
||||
| ETType Exp Exp
|
||||
| ELet [LocDef] Exp
|
||||
| ELetb [LocDef] Exp
|
||||
| EWhere Exp [LocDef]
|
||||
| EEqs [Equation]
|
||||
| EExample Exp String
|
||||
| ELString LString
|
||||
| ELin PIdent
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Exps =
|
||||
NilExp
|
||||
| ConsExp Exp Exps
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Patt =
|
||||
PChar
|
||||
| PChars String
|
||||
| PMacro PIdent
|
||||
| PM PIdent PIdent
|
||||
| PW
|
||||
| PV PIdent
|
||||
| PCon PIdent
|
||||
| PQ PIdent PIdent
|
||||
| PInt Integer
|
||||
| PFloat Double
|
||||
| PStr String
|
||||
| PR [PattAss]
|
||||
| PTup [PattTupleComp]
|
||||
| PC PIdent [Patt]
|
||||
| PQC PIdent PIdent [Patt]
|
||||
| PDisj Patt Patt
|
||||
| PSeq Patt Patt
|
||||
| PRep Patt
|
||||
| PAs PIdent Patt
|
||||
| PNeg Patt
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data PattAss =
|
||||
PA [PIdent] Patt
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Label =
|
||||
LPIdent PIdent
|
||||
| LVar Integer
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Sort =
|
||||
Sort_Type
|
||||
| Sort_PType
|
||||
| Sort_Tok
|
||||
| Sort_Str
|
||||
| Sort_Strs
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Bind =
|
||||
BPIdent PIdent
|
||||
| BWild
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Decl =
|
||||
DDec [Bind] Exp
|
||||
| DExp Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data TupleComp =
|
||||
TComp Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data PattTupleComp =
|
||||
PTComp Patt
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Case =
|
||||
Case Patt Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Equation =
|
||||
Equ [Patt] Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Altern =
|
||||
Alt Exp Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data DDecl =
|
||||
DDDec [Bind] Exp
|
||||
| DDExp Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data OldGrammar =
|
||||
OldGr Include [TopDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Include =
|
||||
NoIncl
|
||||
| Incl [FileName]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data FileName =
|
||||
FString String
|
||||
| FPIdent PIdent
|
||||
| FSlash FileName
|
||||
| FDot FileName
|
||||
| FMinus FileName
|
||||
| FAddId PIdent FileName
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
1089
src-3.0/GF/Devel/Compile/CheckGrammar.hs
Normal file
1089
src-3.0/GF/Devel/Compile/CheckGrammar.hs
Normal file
File diff suppressed because it is too large
Load Diff
205
src-3.0/GF/Devel/Compile/Compile.hs
Normal file
205
src-3.0/GF/Devel/Compile/Compile.hs
Normal file
@@ -0,0 +1,205 @@
|
||||
module GF.Devel.Compile.Compile (batchCompile) where
|
||||
|
||||
-- the main compiler passes
|
||||
import GF.Devel.Compile.GetGrammar
|
||||
import GF.Devel.Compile.Extend
|
||||
import GF.Devel.Compile.Rename
|
||||
import GF.Devel.Compile.CheckGrammar
|
||||
import GF.Devel.Compile.Refresh
|
||||
import GF.Devel.Compile.Optimize
|
||||
import GF.Devel.Compile.Factorize
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import GF.Infra.Ident
|
||||
import GF.Devel.Grammar.PrGF
|
||||
----import GF.Devel.Grammar.Lookup
|
||||
import GF.Devel.Infra.ReadFiles
|
||||
|
||||
import GF.Infra.Option ----
|
||||
import GF.Data.Operations
|
||||
import GF.Devel.UseIO
|
||||
import GF.Devel.Arch
|
||||
|
||||
import Control.Monad
|
||||
import System.Directory
|
||||
|
||||
batchCompile :: Options -> [FilePath] -> IO GF
|
||||
batchCompile opts files = do
|
||||
let defOpts = addOptions opts (options [emitCode])
|
||||
egr <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files
|
||||
case egr of
|
||||
Ok (_,gr) -> return gr
|
||||
Bad s -> error s
|
||||
|
||||
-- to output an intermediate stage
|
||||
intermOut :: Options -> Option -> String -> IOE ()
|
||||
intermOut opts opt s =
|
||||
if oElem opt opts || oElem (iOpt "show_all") opts
|
||||
then
|
||||
ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s)
|
||||
else
|
||||
return ()
|
||||
|
||||
prMod :: SourceModule -> String
|
||||
prMod = prModule
|
||||
|
||||
-- | the environment
|
||||
type CompileEnv = (Int,GF)
|
||||
|
||||
-- | compile with one module as starting point
|
||||
-- command-line options override options (marked by --#) in the file
|
||||
-- As for path: if it is read from file, the file path is prepended to each name.
|
||||
-- If from command line, it is used as it is.
|
||||
|
||||
compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv
|
||||
compileModule opts1 env file = do
|
||||
opts0 <- ioeIO $ getOptionsFromFile file
|
||||
let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
|
||||
let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
|
||||
let opts = addOptions opts1 opts0
|
||||
let fpath = dropFileName file
|
||||
ps0 <- ioeIO $ pathListOpts opts fpath
|
||||
|
||||
let ps1 = if (useFileOpt && not useLineOpt)
|
||||
then (ps0 ++ map (combine fpath) ps0)
|
||||
else ps0
|
||||
ps <- ioeIO $ extendPathEnv ps1
|
||||
let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
|
||||
ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
|
||||
let sgr = snd env
|
||||
let rfs = [] ---- files already in memory and their read times
|
||||
let file' = if useFileOpt then takeFileName file else file -- find file itself
|
||||
files <- getAllFiles opts ps rfs file'
|
||||
ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
|
||||
let names = map justModuleName files
|
||||
ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
|
||||
let sgr2 = sgr ----MGrammar [m | m@(i,_) <- modules sgr,
|
||||
---- notElem (prt i) $ map dropExtension names]
|
||||
let env0 = (0,sgr2)
|
||||
(e,mm) <- foldIOE (compileOne opts) env0 files
|
||||
maybe (return ()) putStrLnE mm
|
||||
return e
|
||||
|
||||
|
||||
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
|
||||
compileOne opts env@(_,srcgr) file = do
|
||||
|
||||
let putp s = putPointE opts ("\n" ++ s)
|
||||
let putpp = putPointEsil opts
|
||||
let putpOpt v m act
|
||||
| oElem beVerbose opts = putp v act
|
||||
| oElem beSilent opts = putpp v act
|
||||
| otherwise = ioeIO (putStrFlush ("\n" ++ m)) >> act
|
||||
|
||||
let gf = takeExtensions file
|
||||
let path = dropFileName file
|
||||
let name = dropExtension file
|
||||
let mos = gfmodules srcgr
|
||||
|
||||
case gf of
|
||||
|
||||
-- for compiled gf, read the file and update environment
|
||||
-- also undo common subexp optimization, to enable normal computations
|
||||
|
||||
".gfn" -> do
|
||||
sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file
|
||||
let sm1 = unsubexpModule sm0
|
||||
sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule srcgr sm1
|
||||
extendCompileEnv env sm
|
||||
|
||||
-- for gf source, do full compilation and generate code
|
||||
_ -> do
|
||||
|
||||
let modu = dropExtension file
|
||||
b1 <- ioeIO $ doesFileExist file
|
||||
if not b1
|
||||
then compileOne opts env $ gfoFile $ modu
|
||||
else do
|
||||
|
||||
sm0 <-
|
||||
putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
|
||||
getSourceModule opts file
|
||||
(k',sm) <- compileSourceModule opts env sm0
|
||||
let sm1 = sm ----
|
||||
---- if isConcr sm then shareModule sm else sm -- cannot expand Str
|
||||
if oElem (iOpt "doemit") opts
|
||||
then putpp " generating code... " $ generateModuleCode opts path sm1
|
||||
else return ()
|
||||
---- -- sm is optimized before generation, but not in the env
|
||||
---- let cm2 = unsubexpModule cm
|
||||
extendCompileEnvInt env (k',sm) ---- sm1
|
||||
where
|
||||
isConcr (_,mi) = case mi of
|
||||
---- ModMod m -> isModCnc m && mstatus m /= MSIncomplete
|
||||
_ -> False
|
||||
|
||||
|
||||
|
||||
compileSourceModule :: Options -> CompileEnv ->
|
||||
SourceModule -> IOE (Int,SourceModule)
|
||||
compileSourceModule opts env@(k,gr) mo@(i,mi) = do
|
||||
|
||||
intermOut opts (iOpt "show_gf") (prMod mo)
|
||||
|
||||
let putp = putPointE opts
|
||||
putpp = putPointEsil opts
|
||||
stopIf n comp m =
|
||||
if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return m else comp m
|
||||
stopIfV v n comp m =
|
||||
if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return (m,v) else comp m
|
||||
|
||||
moe <- stopIf 1 (putpp " extending" . ioeErr . extendModule gr) mo
|
||||
intermOut opts (iOpt "show_extend") (prMod moe)
|
||||
|
||||
mor <- stopIf 2 (putpp " renaming" . ioeErr . renameModule gr) moe
|
||||
intermOut opts (iOpt "show_rename") (prMod mor)
|
||||
|
||||
(moc,warnings) <-
|
||||
stopIfV [] 3 (putpp " type checking" . ioeErr . showCheckModule gr) mor
|
||||
if null warnings then return () else putp warnings $ return ()
|
||||
intermOut opts (iOpt "show_typecheck") (prMod moc)
|
||||
|
||||
(mox,k') <- stopIfV k 4 (putpp " refreshing " . ioeErr . refreshModule k) moc
|
||||
intermOut opts (iOpt "show_refresh") (prMod mox)
|
||||
|
||||
moo <- stopIf 5 (putpp " optimizing " . ioeErr . optimizeModule opts gr) mox
|
||||
intermOut opts (iOpt "show_optimize") (prMod moo)
|
||||
|
||||
mof <- stopIf 6 (putpp " factorizing " . ioeErr . optimizeModule opts gr) moo
|
||||
intermOut opts (iOpt "show_factorize") (prMod mof)
|
||||
|
||||
return (k',moo) ----
|
||||
|
||||
|
||||
generateModuleCode :: Options -> InitPath -> SourceModule -> IOE ()
|
||||
generateModuleCode opts path minfo@(name,info) = do
|
||||
|
||||
let pname = combine path (prt name)
|
||||
let minfo0 = minfo
|
||||
let minfo1 = subexpModule minfo0
|
||||
let minfo2 = minfo1
|
||||
|
||||
let (file,out) = (gfoFile pname, prGF (gfModules [minfo2]))
|
||||
putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ out
|
||||
|
||||
return () ----- minfo2
|
||||
where
|
||||
putp = putPointE opts
|
||||
putpp = putPointEsil opts
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
pathListOpts :: Options -> FileName -> IO [InitPath]
|
||||
pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
|
||||
|
||||
----reverseModules (MGrammar ms) = MGrammar $ reverse ms
|
||||
|
||||
emptyCompileEnv :: CompileEnv
|
||||
emptyCompileEnv = (0,emptyGF)
|
||||
|
||||
extendCompileEnvInt (_,gf) (k,(s,m)) = return (k, addModule s m gf)
|
||||
|
||||
extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm)
|
||||
|
||||
|
||||
26
src-3.0/GF/Devel/Compile/ErrM.hs
Normal file
26
src-3.0/GF/Devel/Compile/ErrM.hs
Normal file
@@ -0,0 +1,26 @@
|
||||
-- BNF Converter: Error Monad
|
||||
-- Copyright (C) 2004 Author: Aarne Ranta
|
||||
|
||||
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
|
||||
module GF.Devel.Compile.ErrM where
|
||||
|
||||
-- the Error monad: like Maybe type with error msgs
|
||||
|
||||
import Control.Monad (MonadPlus(..), liftM)
|
||||
|
||||
data Err a = Ok a | Bad String
|
||||
deriving (Read, Show, Eq, Ord)
|
||||
|
||||
instance Monad Err where
|
||||
return = Ok
|
||||
fail = Bad
|
||||
Ok a >>= f = f a
|
||||
Bad s >>= f = Bad s
|
||||
|
||||
instance Functor Err where
|
||||
fmap = liftM
|
||||
|
||||
instance MonadPlus Err where
|
||||
mzero = Bad "Err.mzero"
|
||||
mplus (Bad _) y = y
|
||||
mplus x _ = x
|
||||
154
src-3.0/GF/Devel/Compile/Extend.hs
Normal file
154
src-3.0/GF/Devel/Compile/Extend.hs
Normal file
@@ -0,0 +1,154 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Extend
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/30 21:08:14 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.18 $
|
||||
--
|
||||
-- AR 14\/5\/2003 -- 11\/11
|
||||
-- 4/12/2007 this module is still very very messy... ----
|
||||
--
|
||||
-- The top-level function 'extendModule'
|
||||
-- extends a module symbol table by indirections to the module it extends
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Compile.Extend (
|
||||
extendModule
|
||||
) where
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import GF.Devel.Grammar.PrGF
|
||||
import GF.Devel.Grammar.Lookup
|
||||
import GF.Devel.Grammar.Macros
|
||||
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.List (nub)
|
||||
import Data.Map
|
||||
import Control.Monad
|
||||
|
||||
extendModule :: GF -> SourceModule -> Err SourceModule
|
||||
extendModule gf nmo0 = do
|
||||
(name,mo) <- rebuildModule gf nmo0
|
||||
case mtype mo of
|
||||
|
||||
---- Just to allow inheritance in incomplete concrete (which are not
|
||||
---- compiled anyway), extensions are not built for them.
|
||||
---- Should be replaced by real control. AR 4/2/2005
|
||||
MTConcrete _ | not (isCompleteModule mo) -> return (name,mo)
|
||||
_ -> do
|
||||
mo' <- foldM (extOne name) mo (mextends mo)
|
||||
return (name, mo')
|
||||
where
|
||||
extOne name mo (n,cond) = do
|
||||
mo0 <- lookupModule gf n
|
||||
|
||||
-- test that the module types match
|
||||
testErr True ---- (legalExtension mo mo0)
|
||||
("illegal extension type to module" +++ prt name)
|
||||
|
||||
-- find out if the old is complete
|
||||
let isCompl = isCompleteModule mo0
|
||||
|
||||
-- if incomplete, remove it from extension list --- because??
|
||||
let me' = (if isCompl then id else (Prelude.filter ((/=n) . fst)))
|
||||
(mextends mo)
|
||||
|
||||
-- build extension depending on whether the old module is complete
|
||||
js0 <- extendMod isCompl n (isInherited cond) name (mjments mo0) (mjments mo)
|
||||
|
||||
return $ mo {mextends = me', mjments = js0}
|
||||
|
||||
-- | When extending a complete module: new information is inserted,
|
||||
-- and the process is interrupted if unification fails.
|
||||
-- If the extended module is incomplete, its judgements are just copied.
|
||||
extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident ->
|
||||
Map Ident Judgement -> Map Ident Judgement ->
|
||||
Err (Map Ident Judgement)
|
||||
extendMod isCompl name cond base old new = foldM try new $ assocs old where
|
||||
try t i@(c,_) | not (cond c) = return t
|
||||
try t i@(c,_) = errIn ("constant" +++ prt c) $
|
||||
tryInsert (extendAnyInfo isCompl name base) indirIf t i
|
||||
indirIf = if isCompl then indirInfo name else id
|
||||
|
||||
indirInfo :: Ident -> Judgement -> Judgement
|
||||
indirInfo n ju = case jform ju of
|
||||
JLink -> ju -- original link is passed
|
||||
_ -> linkInherited (isConstructor ju) n
|
||||
|
||||
extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement
|
||||
extendAnyInfo isc n o i j =
|
||||
errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $
|
||||
unifyJudgement i j
|
||||
|
||||
tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
|
||||
Map a b -> (a,b) -> Err (Map a b)
|
||||
tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of
|
||||
Just info0 -> do
|
||||
info1 <- unif info info0
|
||||
return $ insert x info1 tree
|
||||
_ -> return $ insert x (indir info) tree
|
||||
|
||||
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
||||
-- AR 24/10/2003
|
||||
rebuildModule :: GF -> SourceModule -> Err SourceModule
|
||||
rebuildModule gr mo@(i,mi) = case mtype mi of
|
||||
|
||||
-- copy interface contents to instance
|
||||
MTInstance i0 -> do
|
||||
m0 <- lookupModule gr i0
|
||||
testErr (isInterface m0) ("not an interface:" +++ prt i0)
|
||||
js1 <- extendMod False i0 (const True) i (mjments m0) (mjments mi)
|
||||
|
||||
--- to avoid double inclusions, in instance J of I0 = J0 ** ...
|
||||
case mextends mi of
|
||||
[] -> return $ (i,mi {mjments = js1})
|
||||
es -> do
|
||||
mes <- mapM (lookupModule gr . fst) es ---- restricted?? 12/2007
|
||||
let notInExts c _ = all (notMember c . mjments) mes
|
||||
let js2 = filterWithKey notInExts js1
|
||||
return $ (i,mi {
|
||||
mjments = js2
|
||||
})
|
||||
|
||||
-- copy functor contents to instantiation, and also add opens
|
||||
_ -> case minstances mi of
|
||||
[((ext,incl),ops)] -> do
|
||||
let interfs = Prelude.map fst ops
|
||||
|
||||
-- test that all interfaces are instantiated
|
||||
let isCompl = Prelude.null [i | (_,i) <- minterfaces mi, notElem i interfs]
|
||||
testErr isCompl ("module" +++ prt i +++ "remains incomplete")
|
||||
|
||||
-- look up the functor and build new opens set
|
||||
mi0 <- lookupModule gr ext
|
||||
let
|
||||
ops1 = nub $
|
||||
mopens mi -- own opens; N.B. mi0 has been name-resolved already
|
||||
++ ops -- instantiating opens
|
||||
++ [(n,o) |
|
||||
(n,o) <- mopens mi0, notElem o interfs] -- ftor's non-if opens
|
||||
++ [(i,i) | i <- Prelude.map snd ops] ---- -- insts w. real names
|
||||
|
||||
-- combine flags; new flags have priority
|
||||
let fs1 = union (mflags mi) (mflags mi0)
|
||||
|
||||
-- copy inherited functor judgements
|
||||
let js0 = [ci | ci@(c,_) <- assocs (mjments mi0), isInherited incl c]
|
||||
let js1 = fromList (assocs (mjments mi) ++ js0)
|
||||
|
||||
return $ (i,mi {
|
||||
mflags = fs1,
|
||||
mextends = mextends mi, -- extends of instantiation
|
||||
mopens = ops1,
|
||||
mjments = js1
|
||||
})
|
||||
_ -> return (i,mi)
|
||||
|
||||
251
src-3.0/GF/Devel/Compile/Factorize.hs
Normal file
251
src-3.0/GF/Devel/Compile/Factorize.hs
Normal file
@@ -0,0 +1,251 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : OptimizeGF
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:33 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Optimizations on GF source code: sharing, parametrization, value sets.
|
||||
--
|
||||
-- optimization: sharing branches in tables. AR 25\/4\/2003.
|
||||
-- following advice of Josef Svenningsson
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Compile.Factorize (
|
||||
optModule,
|
||||
unshareModule,
|
||||
unsubexpModule,
|
||||
unoptModule,
|
||||
subexpModule,
|
||||
shareModule
|
||||
) where
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import GF.Devel.Grammar.PrGF (prt)
|
||||
import qualified GF.Devel.Grammar.Macros as C
|
||||
|
||||
import GF.Devel.Grammar.Lookup
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.List
|
||||
|
||||
optModule :: SourceModule -> SourceModule
|
||||
optModule = subexpModule . shareModule
|
||||
|
||||
shareModule = processModule optim
|
||||
|
||||
unoptModule :: GF -> SourceModule -> SourceModule
|
||||
unoptModule gr = unshareModule gr . unsubexpModule
|
||||
|
||||
unshareModule :: GF -> SourceModule -> SourceModule
|
||||
unshareModule gr = processModule (const (unoptim gr))
|
||||
|
||||
processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule
|
||||
processModule opt (i,mo) =
|
||||
(i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)})
|
||||
|
||||
shareInfo :: (Term -> Term) -> Judgement -> Judgement
|
||||
shareInfo opt ju = ju {jdef = opt (jdef ju)}
|
||||
|
||||
-- the function putting together optimizations
|
||||
optim :: Ident -> Term -> Term
|
||||
optim c = values . factor c 0
|
||||
|
||||
-- we need no counter to create new variable names, since variables are
|
||||
-- local to tables ----
|
||||
-- factor parametric branches
|
||||
|
||||
factor :: Ident -> Int -> Term -> Term
|
||||
factor c i t = case t of
|
||||
T _ [_] -> t
|
||||
T _ [] -> t
|
||||
T (TComp ty) cs ->
|
||||
T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
|
||||
_ -> C.composSafeOp (factor c i) t
|
||||
where
|
||||
|
||||
factors i psvs = -- we know psvs has at least 2 elements
|
||||
let p = qqIdent c i
|
||||
vs' = map (mkFun p) psvs
|
||||
in if allEqs vs'
|
||||
then mkCase p vs'
|
||||
else psvs
|
||||
|
||||
mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
|
||||
|
||||
allEqs (v:vs) = all (==v) vs
|
||||
|
||||
mkCase p (v:_) = [(PV p, v)]
|
||||
|
||||
--- we hope this will be fresh and don't check...
|
||||
|
||||
qqIdent c i = identC ("_q_" ++ prt c ++ "__" ++ show i)
|
||||
|
||||
|
||||
-- we need to replace subterms
|
||||
|
||||
replace :: Term -> Term -> Term -> Term
|
||||
replace old new trm = case trm of
|
||||
|
||||
-- these are the important cases, since they can correspond to patterns
|
||||
QC _ _ | trm == old -> new
|
||||
App t ts | trm == old -> new
|
||||
App t ts -> App (repl t) (repl ts)
|
||||
R _ | isRec && trm == old -> new
|
||||
_ -> C.composSafeOp repl trm
|
||||
where
|
||||
repl = replace old new
|
||||
isRec = case trm of
|
||||
R _ -> True
|
||||
_ -> False
|
||||
|
||||
-- It is very important that this is performed only after case
|
||||
-- expansion since otherwise the order and number of values can
|
||||
-- be incorrect. Guaranteed by the TComp flag.
|
||||
|
||||
values :: Term -> Term
|
||||
values t = case t of
|
||||
T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization
|
||||
T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
|
||||
T (TTyped ty) cs -> V ty [values t | (_, t) <- cs]
|
||||
---- why are these left?
|
||||
---- printing with GrammarToSource does not preserve the distinction
|
||||
_ -> C.composSafeOp values t
|
||||
|
||||
|
||||
-- to undo the effect of factorization
|
||||
|
||||
unoptim :: GF -> Term -> Term
|
||||
unoptim gr = unfactor gr
|
||||
|
||||
unfactor :: GF -> Term -> Term
|
||||
unfactor gr t = case t of
|
||||
T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
|
||||
_ -> C.composSafeOp unfac t
|
||||
where
|
||||
unfac = unfactor gr
|
||||
vals = err error id . allParamValues gr
|
||||
restore x u t = case t of
|
||||
Vr y | y == x -> u
|
||||
_ -> C.composSafeOp (restore x u) t
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
{-
|
||||
This module implements a simple common subexpression elimination
|
||||
for gfc grammars, to factor out shared subterms in lin rules.
|
||||
It works in three phases:
|
||||
|
||||
(1) collectSubterms collects recursively all subterms of forms table and (P x..y)
|
||||
from lin definitions (experience shows that only these forms
|
||||
tend to get shared) and counts how many times they occur
|
||||
(2) addSubexpConsts takes those subterms t that occur more than once
|
||||
and creates definitions of form "oper A''n = t" where n is a
|
||||
fresh number; notice that we assume no ids of this form are in
|
||||
scope otherwise
|
||||
(3) elimSubtermsMod goes through lins and the created opers by replacing largest
|
||||
possible subterms by the newly created identifiers
|
||||
|
||||
The optimization is invoked in gf by the flag i -subs.
|
||||
|
||||
If an application does not support GFC opers, the effect of this
|
||||
optimization can be undone by the function unSubelimCanon.
|
||||
|
||||
The function unSubelimCanon can be used to diagnostisize how much
|
||||
cse is possible in the grammar. It is used by the flag pg -printer=subs.
|
||||
|
||||
-}
|
||||
|
||||
subexpModule :: SourceModule -> SourceModule
|
||||
subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of
|
||||
MTAbstract -> return (m,mo)
|
||||
_ -> do
|
||||
let js = listJudgements mo
|
||||
(tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0)
|
||||
js2 <- addSubexpConsts m tree js
|
||||
return (m, mo{mjments = Map.fromList js2})
|
||||
|
||||
unsubexpModule :: SourceModule -> SourceModule
|
||||
unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)})
|
||||
where
|
||||
unparInfo (c, ju) = case jtype ju of
|
||||
EInt 8 -> [] -- subexp-generated opers
|
||||
_ -> [(c, ju {jdef = unparTerm (jdef ju)})]
|
||||
unparTerm t = case t of
|
||||
Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers
|
||||
maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo)
|
||||
_ -> C.composSafeOp unparTerm t
|
||||
rebuild = Map.fromList . concat . map unparInfo . Map.assocs
|
||||
|
||||
-- implementation
|
||||
|
||||
type TermList = Map Term (Int,Int) -- number of occs, id
|
||||
type TermM a = STM (TermList,Int) a
|
||||
|
||||
addSubexpConsts ::
|
||||
Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)]
|
||||
addSubexpConsts mo tree lins = do
|
||||
let opers = [oper id trm | (trm,(_,id)) <- list]
|
||||
mapM mkOne $ opers ++ lins
|
||||
where
|
||||
|
||||
mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)})
|
||||
recomp f t = case Map.lookup t tree of
|
||||
Just (_,id) | ident id /= f -> Q mo (ident id)
|
||||
_ -> C.composSafeOp (recomp f) t
|
||||
|
||||
list = Map.toList tree
|
||||
|
||||
oper id trm = (ident id, resOper (EInt 8) trm)
|
||||
--- impossible type encoding generated opers
|
||||
|
||||
getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int))
|
||||
getSubtermsMod mo js = do
|
||||
mapM (getInfo (collectSubterms mo)) js
|
||||
(tree0,_) <- readSTM
|
||||
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
|
||||
where
|
||||
getInfo get fi@(_,i) = do
|
||||
get (jdef i)
|
||||
return $ fi
|
||||
|
||||
collectSubterms :: Ident -> Term -> TermM Term
|
||||
collectSubterms mo t = case t of
|
||||
App f a -> do
|
||||
collect f
|
||||
collect a
|
||||
add t
|
||||
T ty cs -> do
|
||||
let (_,ts) = unzip cs
|
||||
mapM collect ts
|
||||
add t
|
||||
V ty ts -> do
|
||||
mapM collect ts
|
||||
add t
|
||||
---- K (KP _ _) -> add t
|
||||
_ -> C.composOp (collectSubterms mo) t
|
||||
where
|
||||
collect = collectSubterms mo
|
||||
add t = do
|
||||
(ts,i) <- readSTM
|
||||
let
|
||||
((count,id),next) = case Map.lookup t ts of
|
||||
Just (nu,id) -> ((nu+1,id), i)
|
||||
_ -> ((1, i ), i+1)
|
||||
writeSTM (Map.insert t (count,id) ts, next)
|
||||
return t --- only because of composOp
|
||||
|
||||
ident :: Int -> Ident
|
||||
ident i = identC ("_A" ++ show i) ---
|
||||
|
||||
326
src-3.0/GF/Devel/Compile/GF.cf
Normal file
326
src-3.0/GF/Devel/Compile/GF.cf
Normal file
@@ -0,0 +1,326 @@
|
||||
-- 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] "}" ; --%
|
||||
|
||||
EPatt. Exp4 ::= "pattern" Patt2 ;
|
||||
EPattType. Exp4 ::= "pattern" "type" Exp5 ;
|
||||
|
||||
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
|
||||
|
||||
PChar. Patt2 ::= "?" ;
|
||||
PChars. Patt2 ::= "[" String "]" ;
|
||||
PMacro. Patt2 ::= "#" PIdent ;
|
||||
PM. Patt2 ::= "#" PIdent "." PIdent ;
|
||||
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 ";" ; --%
|
||||
72
src-3.0/GF/Devel/Compile/GFC.hs
Normal file
72
src-3.0/GF/Devel/Compile/GFC.hs
Normal file
@@ -0,0 +1,72 @@
|
||||
module GF.Devel.Compile.GFC (mainGFC) where
|
||||
-- module Main where
|
||||
|
||||
import GF.Devel.Compile.Compile
|
||||
import GF.Devel.Compile.GFtoGFCC
|
||||
import GF.Devel.PrintGFCC
|
||||
import GF.GFCC.OptimizeGFCC
|
||||
import GF.GFCC.CheckGFCC
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.Raw.ParGFCCRaw
|
||||
import GF.GFCC.Raw.ConvertGFCC
|
||||
import GF.Devel.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.GFCC.API
|
||||
import GF.Data.ErrM
|
||||
|
||||
mainGFC :: [String] -> IO ()
|
||||
mainGFC xx = do
|
||||
let (opts,fs) = getOptions "-" xx
|
||||
case opts of
|
||||
_ | oElem (iOpt "help") opts -> putStrLn usageMsg
|
||||
_ | oElem (iOpt "-make") opts -> do
|
||||
gr <- batchCompile opts fs
|
||||
let name = justModuleName (last fs)
|
||||
let (abs,gc0) = mkCanon2gfcc opts name gr
|
||||
gc1 <- checkGFCCio gc0
|
||||
let gc = if oElem (iOpt "noopt") opts then gc1 else optGFCC gc1
|
||||
let target = targetName opts abs
|
||||
let gfccFile = target ++ ".gfcc"
|
||||
writeFile gfccFile (printGFCC gc)
|
||||
putStrLn $ "wrote file " ++ gfccFile
|
||||
mapM_ (alsoPrint opts target gc) printOptions
|
||||
|
||||
-- gfc -o target.gfcc source_1.gfcc ... source_n.gfcc
|
||||
_ | all ((==".gfcc") . takeExtensions) fs -> do
|
||||
gfccs <- mapM file2gfcc fs
|
||||
let gfcc = foldl1 unionGFCC gfccs
|
||||
let abs = printCId $ absname gfcc
|
||||
let target = targetName opts abs
|
||||
let gfccFile = target ++ ".gfcc"
|
||||
writeFile gfccFile (printGFCC gfcc)
|
||||
putStrLn $ "wrote file " ++ gfccFile
|
||||
mapM_ (alsoPrint opts target gfcc) printOptions
|
||||
|
||||
_ -> do
|
||||
mapM_ (batchCompile opts) (map return fs)
|
||||
putStrLn "Done."
|
||||
|
||||
targetName opts abs = case getOptVal opts (aOpt "target") of
|
||||
Just n -> n
|
||||
_ -> abs
|
||||
|
||||
---- TODO: nicer and richer print options
|
||||
|
||||
alsoPrint opts abs gr (opt,name) = do
|
||||
if oElem (iOpt opt) opts
|
||||
then do
|
||||
let outfile = name
|
||||
let output = prGFCC opt gr
|
||||
writeFile outfile output
|
||||
putStrLn $ "wrote file " ++ outfile
|
||||
else return ()
|
||||
|
||||
printOptions = [
|
||||
("haskell","GSyntax.hs"),
|
||||
("haskell_gadt","GSyntax.hs"),
|
||||
("js","grammar.js"),
|
||||
("jsref","grammarReference.js")
|
||||
]
|
||||
|
||||
usageMsg =
|
||||
"usage: gfc (-h | --make (-noopt) (-target=PREFIX) (-js | -jsref | -haskell | -haskell_gadt)) (-src) FILES"
|
||||
542
src-3.0/GF/Devel/Compile/GFtoGFCC.hs
Normal file
542
src-3.0/GF/Devel/Compile/GFtoGFCC.hs
Normal file
@@ -0,0 +1,542 @@
|
||||
module GF.Devel.Compile.GFtoGFCC (prGrammar2gfcc,mkCanon2gfcc) where
|
||||
|
||||
import GF.Devel.Compile.Factorize (unshareModule)
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import qualified GF.Devel.Grammar.Lookup as Look
|
||||
|
||||
import qualified GF.Devel.Grammar.Grammar as A ----
|
||||
import qualified GF.Devel.Grammar.Grammar as M ----
|
||||
import qualified GF.Devel.Grammar.Macros as GM
|
||||
--import qualified GF.Grammar.Compute as Compute
|
||||
|
||||
import GF.Devel.Grammar.PrGF
|
||||
--import GF.Devel.ModDeps
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Devel.PrintGFCC
|
||||
import qualified GF.GFCC.Macros as CM
|
||||
import qualified GF.GFCC.DataGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import GF.GFCC.CId
|
||||
import GF.Infra.Option ----
|
||||
import GF.Data.Operations
|
||||
import GF.Text.UTF8
|
||||
|
||||
import Data.List
|
||||
import Data.Char (isDigit,isSpace)
|
||||
import qualified Data.Map as Map
|
||||
import Debug.Trace ----
|
||||
|
||||
-- the main function: generate GFCC from GF.
|
||||
|
||||
prGrammar2gfcc :: Options -> String -> GF -> (String,String)
|
||||
prGrammar2gfcc opts cnc gr = (abs, printGFCC gc) where
|
||||
(abs,gc) = mkCanon2gfcc opts cnc gr
|
||||
|
||||
mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC)
|
||||
mkCanon2gfcc opts cnc gr =
|
||||
(prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
|
||||
where
|
||||
abs = err error id $ Look.abstractOfConcrete gr (identC cnc)
|
||||
pars = mkParamLincat gr
|
||||
|
||||
-- Generate GFCC from GFCM.
|
||||
-- this assumes a grammar translated by canon2canon
|
||||
|
||||
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> GF -> D.GFCC
|
||||
canon2gfcc opts pars cgr =
|
||||
(if (oElem (iOpt "show_canon") opts) then trace (prt cgr) else id) $
|
||||
D.GFCC an cns gflags abs cncs
|
||||
where
|
||||
-- recognize abstract and concretes
|
||||
([(a,abm)],cms) =
|
||||
partition ((== MTAbstract) . mtype . snd) (Map.toList (gfmodules cgr))
|
||||
|
||||
-- abstract
|
||||
an = (i2i a)
|
||||
cns = map (i2i . fst) cms
|
||||
abs = D.Abstr aflags funs cats catfuns
|
||||
gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
|
||||
where fg = "firstlang"
|
||||
aflags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)]
|
||||
mkDef pty = case pty of
|
||||
Meta _ -> CM.primNotion
|
||||
t -> mkExp t
|
||||
|
||||
funs = Map.fromAscList lfuns
|
||||
cats = Map.fromAscList lcats
|
||||
|
||||
lfuns = [(i2i f, (mkType (jtype ju), mkDef (jdef ju))) |
|
||||
(f,ju) <- listJudgements abm, jform ju == JFun]
|
||||
lcats = [(i2i c, mkContext (GM.contextOfType (jtype ju))) |
|
||||
(c,ju) <- listJudgements abm, jform ju == JCat]
|
||||
catfuns = Map.fromList
|
||||
[(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
|
||||
|
||||
-- concretes
|
||||
cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
|
||||
mkConcr lang0 lang mo =
|
||||
(lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
|
||||
where
|
||||
js = listJudgements mo
|
||||
flags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)]
|
||||
opers = Map.fromAscList [] -- opers will be created as optimization
|
||||
utf = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ----
|
||||
then D.convertStringsInTerm decodeUTF8 else id
|
||||
lins = Map.fromAscList
|
||||
[(i2i f, utf (mkTerm (jdef ju))) | (f,ju) <- js, jform ju == JLin]
|
||||
lincats = Map.fromAscList
|
||||
[(i2i c, utf (mkTerm (jtype ju))) | (c,ju) <- js, jform ju == JLincat]
|
||||
lindefs = Map.fromAscList
|
||||
[(i2i c, utf (mkTerm (jdef ju))) | (c,ju) <- js, jform ju == JLincat]
|
||||
printnames = Map.fromAscList
|
||||
[(i2i c, utf (mkTerm (jprintname ju))) |
|
||||
(c,ju) <- js, elem (jform ju) [JLincat,JLin]]
|
||||
params = Map.fromAscList
|
||||
[(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ??
|
||||
fcfg = Nothing
|
||||
|
||||
i2i :: Ident -> CId
|
||||
i2i = CId . prIdent
|
||||
|
||||
mkType :: A.Type -> C.Type
|
||||
mkType t = case GM.typeForm t of
|
||||
(hyps,(Q _ cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
|
||||
|
||||
mkExp :: A.Term -> C.Exp
|
||||
mkExp t = case t of
|
||||
A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
|
||||
_ -> case GM.termForm t of
|
||||
(xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args)
|
||||
where
|
||||
mkAt c = case c of
|
||||
Q _ c -> C.AC $ i2i c
|
||||
QC _ c -> C.AC $ i2i c
|
||||
Vr x -> C.AV $ i2i x
|
||||
EInt i -> C.AI i
|
||||
EFloat f -> C.AF f
|
||||
K s -> C.AS s
|
||||
Meta i -> C.AM $ toInteger i
|
||||
_ -> C.AM 0
|
||||
mkPatt p = uncurry CM.tree $ case p of
|
||||
A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps)
|
||||
A.PV x -> (C.AV (i2i x), [])
|
||||
A.PW -> (C.AV CM.wildCId, [])
|
||||
A.PInt i -> (C.AI i, [])
|
||||
|
||||
mkContext :: A.Context -> [C.Hypo]
|
||||
mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
|
||||
|
||||
mkTerm :: Term -> C.Term
|
||||
mkTerm tr = case tr of
|
||||
Vr (IA (_,i)) -> C.V i
|
||||
Vr (IC s) | isDigit (last s) ->
|
||||
C.V (read (reverse (takeWhile (/='_') (reverse s))))
|
||||
---- from gf parser of gfc
|
||||
EInt i -> C.C $ fromInteger i
|
||||
R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
|
||||
P t l -> C.P (mkTerm t) (C.C (mkLab l))
|
||||
T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
|
||||
V _ cs -> C.R [mkTerm t | t <- cs]
|
||||
S t p -> C.P (mkTerm t) (mkTerm p)
|
||||
C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]]
|
||||
FV ts -> C.FV [mkTerm t | t <- ts]
|
||||
K s -> C.K (C.KS s)
|
||||
----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
|
||||
Empty -> C.S []
|
||||
App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
|
||||
Abs _ t -> mkTerm t ---- only on toplevel
|
||||
Alts (td,tvs) ->
|
||||
C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs])
|
||||
_ -> prtTrace tr $ C.S [C.K (C.KS (prt tr +++ "66662"))] ---- for debugging
|
||||
where
|
||||
mkLab (LIdent l) = case l of
|
||||
'_':ds -> (read ds) :: Int
|
||||
_ -> prtTrace tr $ 66663
|
||||
strings t = case t of
|
||||
K s -> [s]
|
||||
C u v -> strings u ++ strings v
|
||||
FV ss -> concatMap strings ss
|
||||
_ -> prtTrace tr $ ["66660"]
|
||||
flats t = case t of
|
||||
C.S ts -> concatMap flats ts
|
||||
_ -> [t]
|
||||
|
||||
-- encoding GFCC-internal lincats as terms
|
||||
mkCType :: Type -> C.Term
|
||||
mkCType t = case t of
|
||||
EInt i -> C.C $ fromInteger i
|
||||
RecType rs -> C.R [mkCType t | (_, t) <- rs]
|
||||
Table pt vt -> case pt of
|
||||
EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
|
||||
RecType rs -> mkCType $ foldr Table vt (map snd rs)
|
||||
Sort "Str" -> C.S [] --- Str only
|
||||
App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i
|
||||
_ -> error $ "mkCType " ++ show t
|
||||
|
||||
-- encoding showable lincats (as in source gf) as terms
|
||||
mkParamLincat :: GF -> Ident -> Ident -> C.Term
|
||||
mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
|
||||
typ <- Look.lookupLincat sgr lang cat
|
||||
mkPType typ
|
||||
where
|
||||
mkPType typ = case typ of
|
||||
RecType lts -> do
|
||||
ts <- mapM (mkPType . snd) lts
|
||||
return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts]
|
||||
Table (RecType lts) v -> do
|
||||
ps <- mapM (mkPType . snd) lts
|
||||
v' <- mkPType v
|
||||
return $ foldr (\p v -> C.S [p,v]) v' ps
|
||||
Table p v -> do
|
||||
p' <- mkPType p
|
||||
v' <- mkPType v
|
||||
return $ C.S [p',v']
|
||||
Sort "Str" -> return $ C.S []
|
||||
_ -> return $
|
||||
C.FV $ map (kks . filter showable . prt_) $
|
||||
errVal [] $ Look.allParamValues sgr typ
|
||||
showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records
|
||||
kks = C.K . C.KS
|
||||
|
||||
-- return just one module per language
|
||||
|
||||
reorder :: Ident -> GF -> GF
|
||||
reorder abs cg = emptyGF {
|
||||
gfabsname = Just abs,
|
||||
gfcncnames = (map fst cncs),
|
||||
gfmodules = Map.fromList ((abs,absm) : map mkCnc cncs)
|
||||
}
|
||||
where
|
||||
absm = emptyModule {
|
||||
mtype = MTAbstract,
|
||||
mflags = aflags,
|
||||
mjments = adefs
|
||||
}
|
||||
mkCnc (c,cnc) = (c,emptyModule {
|
||||
mtype = MTConcrete abs,
|
||||
mflags = fst cnc,
|
||||
mjments = snd cnc
|
||||
})
|
||||
|
||||
mos = Map.toList $ gfmodules cg
|
||||
|
||||
adefs = Map.fromAscList $ sortIds $
|
||||
predefADefs ++ Look.allOrigJudgements cg abs
|
||||
predefADefs =
|
||||
[(IC c, absCat []) | c <- ["Float","Int","String"]]
|
||||
aflags = Map.fromList $ nubByFst $ concat
|
||||
[Map.toList (M.mflags mo) | (_,mo) <- mos, mtype mo == MTAbstract] ----toom
|
||||
|
||||
cncs = sortIds [(lang, concr lang) | lang <- Look.allConcretes cg abs]
|
||||
concr la = (
|
||||
Map.fromList (nubByFst flags),
|
||||
Map.fromList (sortIds (predefCDefs ++ jments))
|
||||
) where
|
||||
jments = Look.allOrigJudgements cg la
|
||||
flags = Look.lookupFlags cg la
|
||||
----concat [M.mflags mo |
|
||||
---- (i,mo) <- mos, M.isModCnc mo,
|
||||
---- Just r <- [lookup i (M.allExtendSpecs cg la)]]
|
||||
|
||||
predefCDefs = [(IC c, cncCat GM.defLinType) |
|
||||
---- lindef,printname
|
||||
c <- ["Float","Int","String"]]
|
||||
|
||||
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
|
||||
|
||||
nubByFst = nubBy (\ (f,_) (g,_) -> f == g)
|
||||
|
||||
|
||||
-- one grammar per language - needed for symtab generation
|
||||
repartition :: Ident -> GF -> [GF]
|
||||
repartition abs cg = [Look.partOfGrammar cg (lang,mo) |
|
||||
let mos = gfmodules cg,
|
||||
lang <- Look.allConcretes cg abs,
|
||||
let mo = errVal
|
||||
(error ("no module found for " ++ prt lang)) $ Look.lookupModule cg lang
|
||||
]
|
||||
|
||||
|
||||
-- translate tables and records to arrays, parameters and labels to indices
|
||||
|
||||
canon2canon :: Ident -> GF -> GF
|
||||
canon2canon abs gf = errVal gf $ GM.termOpGF t2t gf where
|
||||
t2t = return . term2term gf pv
|
||||
ty2ty = type2type gf pv
|
||||
pv@(labels,untyps,typs) = paramValues gf
|
||||
---- should be done lang for lang
|
||||
---- ty2ty should be used for types, t2t only in concrete
|
||||
|
||||
{- ----
|
||||
gfModules . nubModules . map cl2cl . repartition abs . purgeGrammar abs
|
||||
where
|
||||
nubModules = Map.fromList . nubByFst . concatMap (Map.toList . gfmodules)
|
||||
|
||||
cl2cl gf = errVal gf $ GM.moduleOpGF (js2js . map (GM.judgementOpModule p2p)) gf
|
||||
|
||||
js2js ms = map (GM.judgementOpModule (j2j (gfModules ms))) ms
|
||||
|
||||
j2j cg (f,j) = case jform j of
|
||||
JLin -> (f, j{jdef = t2t (jdef j)})
|
||||
JLincat -> (f, j{jdef = t2t (jdef j), jtype = ty2ty (jtype j)})
|
||||
_ -> (f,j)
|
||||
where
|
||||
t2t = term2term cg pv
|
||||
ty2ty = type2type cg pv
|
||||
pv@(labels,untyps,typs) = paramValues cg ---trs $ paramValues cg
|
||||
|
||||
-- flatten record arguments of param constructors
|
||||
p2p (f,j) = case jform j of
|
||||
---- JParam ->
|
||||
----ResParam (Yes (ps,v)) ->
|
||||
----(f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing)))
|
||||
_ -> (f,j)
|
||||
unRec (x,ty) = case ty of
|
||||
RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)]
|
||||
_ -> [(x,ty)]
|
||||
|
||||
----
|
||||
trs v = trace (tr v) v
|
||||
|
||||
tr (labels,untyps,typs) =
|
||||
("labels:" ++++
|
||||
unlines [prt c ++ "." ++ unwords (map prt l) +++ "=" +++ show i |
|
||||
((c,l),i) <- Map.toList labels]) ++
|
||||
("untyps:" ++++ unlines [prt t +++ "=" +++ show i |
|
||||
(t,i) <- Map.toList untyps]) ++
|
||||
("typs:" ++++ unlines [prt t |
|
||||
(t,_) <- Map.toList typs])
|
||||
----
|
||||
-}
|
||||
|
||||
purgeGrammar :: Ident -> GF -> GF
|
||||
purgeGrammar abstr gr = gr {
|
||||
gfmodules = treat gr
|
||||
}
|
||||
where
|
||||
treat =
|
||||
Map.fromList . map unopt . filter complete . purge . Map.toList . gfmodules
|
||||
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
|
||||
needed =
|
||||
nub $ concatMap (Look.allDepsModule gr) $
|
||||
---- (requiredCanModules True gr) $
|
||||
[mo | m <- abstr : Look.allConcretes gr abstr,
|
||||
Ok mo <- [Look.lookupModule gr m]]
|
||||
|
||||
complete (i,mo) = isCompleteModule mo
|
||||
unopt = unshareModule gr -- subexp elim undone when compiled
|
||||
|
||||
type ParamEnv =
|
||||
(Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
|
||||
Map.Map Term Integer, -- untyped terms to values
|
||||
Map.Map Type (Map.Map Term Integer)) -- types to their terms to values
|
||||
|
||||
--- gathers those param types that are actually used in lincats and lin terms
|
||||
paramValues :: GF -> ParamEnv
|
||||
paramValues cgr = (labels,untyps,typs) where
|
||||
|
||||
jments = [(m,j) |
|
||||
(m,mo) <- Map.toList (gfmodules cgr),
|
||||
j <- Map.toList (mjments mo)]
|
||||
|
||||
partyps = nub $ [ty |
|
||||
(_,(_,ju)) <- jments,
|
||||
jform ju == JLincat,
|
||||
RecType ls <- [jtype ju],
|
||||
ty0 <- [ty | (_, ty) <- unlockTyp ls],
|
||||
ty <- typsFrom ty0
|
||||
] ++ [Q m ty |
|
||||
(m,(ty,ju)) <- jments,
|
||||
jform ju == JParam
|
||||
] ++ [ty |
|
||||
(_,(_,ju)) <- jments,
|
||||
jform ju == JLin,
|
||||
ty <- err (const []) snd $ appSTM (typsFromTrm (jdef ju)) []
|
||||
]
|
||||
params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
|
||||
typsFrom ty = case ty of
|
||||
Table p t -> typsFrom p ++ typsFrom t
|
||||
RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls]
|
||||
_ -> [ty]
|
||||
|
||||
typsFromTrm :: Term -> STM [Type] Term
|
||||
typsFromTrm tr = case tr of
|
||||
R fs -> mapM_ (typsFromField . snd) fs >> return tr
|
||||
where
|
||||
typsFromField (mty, t) = case mty of
|
||||
Just x -> updateSTM (x:) >> typsFromTrm t
|
||||
_ -> typsFromTrm t
|
||||
V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
|
||||
T (TTyped ty) cs ->
|
||||
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
|
||||
T (TComp ty) cs ->
|
||||
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
|
||||
_ -> GM.composOp typsFromTrm tr
|
||||
|
||||
typs =
|
||||
Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
|
||||
untyps =
|
||||
Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
|
||||
lincats =
|
||||
[(IC cat,[(LIdent "s",typeStr)]) | cat <- ["Int", "Float", "String"]] ++
|
||||
reverse ---- TODO: really those lincats that are reached
|
||||
---- reverse is enough to expel overshadowed ones...
|
||||
[(cat,(unlockTyp ls)) |
|
||||
(_,(cat,ju)) <- jments,
|
||||
jform ju == JLincat,
|
||||
RecType ls <- [jtype ju]
|
||||
]
|
||||
labels = Map.fromList $ concat
|
||||
[((cat,[lab]),(typ,i)):
|
||||
[((cat,[lab,lab2]),(ty,j)) |
|
||||
rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]]
|
||||
|
|
||||
(cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]]
|
||||
-- go to tables recursively
|
||||
---- TODO: even go to deeper records
|
||||
where
|
||||
getRec typ = case typ of
|
||||
RecType rs -> [rs]
|
||||
Table _ t -> getRec t
|
||||
_ -> []
|
||||
|
||||
type2type :: GF -> ParamEnv -> Type -> Type
|
||||
type2type cgr env@(labels,untyps,typs) ty = case ty of
|
||||
RecType rs ->
|
||||
RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
|
||||
Table pt vt -> Table (t2t pt) (t2t vt)
|
||||
QC _ _ -> look ty
|
||||
_ -> ty
|
||||
where
|
||||
t2t = type2type cgr env
|
||||
look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
|
||||
Just vs -> length $ Map.assocs vs
|
||||
_ -> trace ("unknown partype " ++ show ty) 66669
|
||||
|
||||
term2term :: GF -> ParamEnv -> Term -> Term
|
||||
term2term cgr env@(labels,untyps,typs) tr = case tr of
|
||||
App _ _ -> mkValCase (unrec tr)
|
||||
QC _ _ -> mkValCase tr
|
||||
R rs -> R [(mkLab i, (Nothing, t2t t)) |
|
||||
(i,(l,(_,t))) <- zip [0..] (sort (unlock rs))]
|
||||
P t l -> r2r tr
|
||||
PI t l i -> EInt $ toInteger i
|
||||
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
|
||||
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
|
||||
V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
|
||||
S t p -> mkCurrySel (t2t t) (t2t p)
|
||||
_ -> GM.composSafeOp t2t tr
|
||||
where
|
||||
t2t = term2term cgr env
|
||||
|
||||
unrec t = case t of
|
||||
App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
|
||||
_ -> GM.composSafeOp unrec t
|
||||
|
||||
mkValCase tr = case appSTM (doVar tr) [] of
|
||||
Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
|
||||
_ -> valNum $ comp tr
|
||||
|
||||
--- this is mainly needed for parameter record projections
|
||||
---- was: errVal t $ Compute.computeConcreteRec cgr t
|
||||
comp t = case t of
|
||||
T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should...
|
||||
T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should
|
||||
V typ ts -> V typ (map comp ts)
|
||||
S (V typ ts) v0 -> err error id $ do
|
||||
let v = comp v0
|
||||
return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps
|
||||
R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r]
|
||||
P (R r) l -> maybe t (comp . snd) $ lookup l r
|
||||
_ -> GM.composSafeOp comp t
|
||||
|
||||
doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
|
||||
doVar tr = case getLab tr of
|
||||
Ok (cat, lab) -> do
|
||||
k <- readSTM >>= return . length
|
||||
let tr' = Vr $ identC $ show k -----
|
||||
|
||||
let tyvs = case Map.lookup (cat,lab) labels of
|
||||
Just (ty,_) -> case Map.lookup ty typs of
|
||||
Just vs -> (ty,[t |
|
||||
(t,_) <- sortBy (\x y -> compare (snd x) (snd y))
|
||||
(Map.assocs vs)])
|
||||
_ -> error $ prt ty
|
||||
_ -> error $ prt tr
|
||||
updateSTM ((tyvs, (tr', tr)):)
|
||||
return tr'
|
||||
_ -> GM.composOp doVar tr
|
||||
|
||||
r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
|
||||
|
||||
r2r tr@(P p _) = case getLab tr of
|
||||
Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $
|
||||
Map.lookup (cat,labs) labels
|
||||
_ -> K ((prt tr +++ prtTrace tr "66665"))
|
||||
|
||||
-- this goes recursively into tables (ignored) and records (accumulated)
|
||||
getLab tr = case tr of
|
||||
Vr (IA (cat, _)) -> return (identC cat,[])
|
||||
Vr (IC s) -> return (identC cat,[]) where
|
||||
cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
|
||||
---- Vr _ -> error $ "getLab " ++ show tr
|
||||
P p lab2 -> do
|
||||
(cat,labs) <- getLab p
|
||||
return (cat,labs++[lab2])
|
||||
S p _ -> getLab p
|
||||
_ -> Bad "getLab"
|
||||
|
||||
|
||||
mkCase ((ty,vs),(x,p)) tr =
|
||||
S (V ty [mkBranch x v tr | v <- vs]) p
|
||||
mkBranch x t tr = case tr of
|
||||
_ | tr == x -> t
|
||||
_ -> GM.composSafeOp (mkBranch x t) tr
|
||||
|
||||
valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
|
||||
where
|
||||
tryFV tr = case GM.appForm tr of
|
||||
(c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
|
||||
(FV ts,_) -> ts
|
||||
_ -> [tr]
|
||||
valNumFV ts = case ts of
|
||||
[tr] -> trace (unwords (map prt (Map.keys typs))) $
|
||||
prtTrace tr $ K "66667"
|
||||
_ -> FV $ map valNum ts
|
||||
|
||||
mkCurry trm = case trm of
|
||||
V (RecType [(_,ty)]) ts -> V ty ts
|
||||
V (RecType ((_,ty):ltys)) ts ->
|
||||
V ty [mkCurry (V (RecType ltys) cs) |
|
||||
cs <- chop (product (map (lengthtyp . snd) ltys)) ts]
|
||||
_ -> trm
|
||||
lengthtyp ty = case Map.lookup ty typs of
|
||||
Just m -> length (Map.assocs m)
|
||||
_ -> error $ "length of type " ++ show ty
|
||||
chop i xs = case splitAt i xs of
|
||||
(xs1,[]) -> [xs1]
|
||||
(xs1,xs2) -> xs1:chop i xs2
|
||||
|
||||
|
||||
mkCurrySel t p = S t p -- done properly in CheckGFCC
|
||||
|
||||
|
||||
mkLab k = LIdent (("_" ++ show k))
|
||||
|
||||
-- remove lock fields; in fact, any empty records and record types
|
||||
unlock = filter notlock where
|
||||
notlock (l,(_, t)) = case t of --- need not look at l
|
||||
R [] -> False
|
||||
_ -> True
|
||||
unlockTyp = filter notlock where
|
||||
notlock (l, t) = case t of --- need not look at l
|
||||
RecType [] -> False
|
||||
_ -> True
|
||||
|
||||
prtTrace tr n =
|
||||
trace ("-- INTERNAL COMPILER ERROR" +++ prt tr ++++ show n) n
|
||||
prTrace tr n = trace ("-- OBSERVE" +++ prt tr +++ show n +++ show tr) n
|
||||
|
||||
56
src-3.0/GF/Devel/Compile/GetGrammar.hs
Normal file
56
src-3.0/GF/Devel/Compile/GetGrammar.hs
Normal file
@@ -0,0 +1,56 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GetGrammar
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/15 17:56:13 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.16 $
|
||||
--
|
||||
-- this module builds the internal GF grammar that is sent to the type checker
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Compile.GetGrammar where
|
||||
|
||||
import GF.Devel.UseIO
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
----import GF.Devel.PrGrammar
|
||||
import GF.Devel.Compile.SourceToGF
|
||||
---- import Macros
|
||||
---- import Rename
|
||||
--- import Custom
|
||||
import GF.Devel.Compile.ParGF
|
||||
import qualified GF.Devel.Compile.LexGF as L
|
||||
|
||||
import GF.Data.Operations
|
||||
import qualified GF.Devel.Compile.ErrM as E ----
|
||||
import GF.Infra.Option ----
|
||||
import GF.Devel.ReadFiles ----
|
||||
|
||||
import Data.Char (toUpper)
|
||||
import Data.List (nub)
|
||||
import Control.Monad (foldM)
|
||||
import System (system)
|
||||
|
||||
getSourceModule :: Options -> FilePath -> IOE SourceModule
|
||||
getSourceModule opts file0 = do
|
||||
file <- case getOptVal opts usePreprocessor of
|
||||
Just p -> do
|
||||
let tmp = "_gf_preproc.tmp"
|
||||
cmd = p +++ file0 ++ ">" ++ tmp
|
||||
ioeIO $ system cmd
|
||||
-- ioeIO $ putStrLn $ "preproc" +++ cmd
|
||||
return tmp
|
||||
_ -> return file0
|
||||
string <- readFileIOE file
|
||||
let tokens = myLexer string
|
||||
mo1 <- ioeErr $ err2err $ pModDef tokens
|
||||
ioeErr $ transModDef mo1
|
||||
|
||||
err2err e = case e of
|
||||
E.Ok v -> Ok v
|
||||
E.Bad s -> Bad s
|
||||
|
||||
343
src-3.0/GF/Devel/Compile/LexGF.hs
Normal file
343
src-3.0/GF/Devel/Compile/LexGF.hs
Normal file
File diff suppressed because one or more lines are too long
333
src-3.0/GF/Devel/Compile/Optimize.hs
Normal file
333
src-3.0/GF/Devel/Compile/Optimize.hs
Normal file
@@ -0,0 +1,333 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Optimize
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/16 13:56:13 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.18 $
|
||||
--
|
||||
-- Top-level partial evaluation for GF source modules.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Compile.Optimize (optimizeModule) where
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import GF.Devel.Grammar.Macros
|
||||
--import GF.Devel.Grammar.PrGF
|
||||
import GF.Devel.Grammar.Compute
|
||||
|
||||
--import GF.Infra.Ident
|
||||
|
||||
import GF.Devel.Grammar.Lookup
|
||||
--import GF.Grammar.Refresh
|
||||
|
||||
--import GF.Compile.BackOpt
|
||||
import GF.Devel.Compile.CheckGrammar
|
||||
--import GF.Compile.Update
|
||||
|
||||
|
||||
--import GF.Infra.CheckM
|
||||
import GF.Infra.Option ----
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
|
||||
optimizeModule :: Options -> GF -> SourceModule -> Err SourceModule
|
||||
optimizeModule opts gf0 sm@(m,mo) = case mtype mo of
|
||||
MTConcrete _ -> opt sm
|
||||
MTInstance _ -> optr sm
|
||||
MTGrammar -> optr sm
|
||||
_ -> return sm
|
||||
where
|
||||
gf = gf0 {gfmodules = Map.insert m mo (gfmodules gf0)}
|
||||
opt (m,mo) = do
|
||||
mo' <- termOpModule (computeTerm gf) mo
|
||||
return (m,mo')
|
||||
|
||||
optr (m,mo)= do
|
||||
let deps = allOperDependencies m $ mjments mo
|
||||
ids <- topoSortOpers deps
|
||||
gf' <- foldM evalOp gf ids
|
||||
mo' <- lookupModule gf' m
|
||||
return $ (m,mo')
|
||||
where
|
||||
evalOp gf i = do
|
||||
ju <- lookupJudgement gf m i
|
||||
def' <- computeTerm gf (jdef ju)
|
||||
updateJudgement m i (ju {jdef = def'}) gf
|
||||
|
||||
|
||||
|
||||
|
||||
{-
|
||||
|
||||
-- conditional trace
|
||||
|
||||
prtIf :: (Print a) => Bool -> a -> a
|
||||
prtIf b t = if b then trace (" " ++ prt t) t else t
|
||||
|
||||
-- | partial evaluation of concrete syntax.
|
||||
-- AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005 -- 7/12/2007
|
||||
|
||||
type EEnv = () --- not used
|
||||
|
||||
-- only do this for resource: concrete is optimized in gfc form
|
||||
|
||||
|
||||
|
||||
=mse@(ms,eenv) mo@(_,mi) = case mi of
|
||||
ModMod m0@(Module mt st fs me ops js) |
|
||||
st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
|
||||
(mo1,_) <- evalModule oopts mse mo
|
||||
let
|
||||
mo2 = case optim of
|
||||
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
|
||||
"values" -> shareModule valOpt mo1 -- tables as courses-of-values
|
||||
"share" -> shareModule shareOpt mo1 -- sharing of branches
|
||||
"all" -> shareModule allOpt mo1 -- first parametrize then values
|
||||
"none" -> mo1 -- no optimization
|
||||
_ -> mo1 -- none; default for src
|
||||
return (mo2,eenv)
|
||||
_ -> evalModule oopts mse mo
|
||||
where
|
||||
oopts = addOptions opts (iOpts (flagsModule mo))
|
||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
||||
|
||||
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
|
||||
Err ((Ident,SourceModInfo),EEnv)
|
||||
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
|
||||
|
||||
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
|
||||
_ | isModRes m0 && not (oElem oEval oopts) -> do
|
||||
let deps = allOperDependencies name js
|
||||
ids <- topoSortOpers deps
|
||||
MGrammar (mod' : _) <- foldM evalOp gr ids
|
||||
return $ (mod',eenv)
|
||||
|
||||
MTConcrete a -> do
|
||||
js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
|
||||
return $ ((name, ModMod (Module mt st fs me ops js')),eenv)
|
||||
|
||||
_ -> return $ ((name,mod),eenv)
|
||||
_ -> return $ ((name,mod),eenv)
|
||||
where
|
||||
gr0 = MGrammar $ ms
|
||||
gr = MGrammar $ (name,mod) : ms
|
||||
|
||||
evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
|
||||
info <- lookupTree prt i $ jments m
|
||||
info' <- evalResInfo oopts gr (i,info)
|
||||
return $ updateRes g name i info'
|
||||
|
||||
-- | only operations need be compiled in a resource, and this is local to each
|
||||
-- definition since the module is traversed in topological order
|
||||
evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
|
||||
evalResInfo oopts gr (c,info) = case info of
|
||||
|
||||
ResOper pty pde -> eIn "operation" $ do
|
||||
pde' <- case pde of
|
||||
Yes de | optres -> liftM yes $ comp de
|
||||
_ -> return pde
|
||||
return $ ResOper pty pde'
|
||||
|
||||
_ -> return info
|
||||
where
|
||||
comp = if optres then computeConcrete gr else computeConcreteRec gr
|
||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
||||
optres = case optim of
|
||||
"noexpand" -> False
|
||||
_ -> True
|
||||
|
||||
|
||||
evalCncInfo ::
|
||||
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
|
||||
evalCncInfo opts gr cnc abs (c,info) = do
|
||||
|
||||
seq (prtIf (oElem beVerbose opts) c) $ return ()
|
||||
|
||||
errIn ("optimizing" +++ prt c) $ case info of
|
||||
|
||||
CncCat ptyp pde ppr -> do
|
||||
pde' <- case (ptyp,pde) of
|
||||
(Yes typ, Yes de) ->
|
||||
liftM yes $ pEval ([(strVar, typeStr)], typ) de
|
||||
(Yes typ, Nope) ->
|
||||
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
|
||||
(May b, Nope) ->
|
||||
return $ May b
|
||||
_ -> return pde -- indirection
|
||||
|
||||
ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
|
||||
|
||||
return (c, CncCat ptyp pde' ppr')
|
||||
|
||||
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
|
||||
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
|
||||
pde' <- case pde of
|
||||
Yes de | notNewEval -> do
|
||||
liftM yes $ pEval ty de
|
||||
|
||||
_ -> return pde
|
||||
ppr' <- liftM yes $ evalPrintname gr c ppr pde'
|
||||
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
|
||||
|
||||
_ -> return (c,info)
|
||||
where
|
||||
pEval = partEval opts gr
|
||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||
notNewEval = not (oElem oEval opts)
|
||||
|
||||
-- | the main function for compiling linearizations
|
||||
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
|
||||
partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
|
||||
let vars = map fst context
|
||||
args = map Vr vars
|
||||
subst = [(v, Vr v) | v <- vars]
|
||||
trm1 = mkApp trm args
|
||||
trm3 <- if globalTable
|
||||
then etaExpand subst trm1 >>= outCase subst
|
||||
else etaExpand subst trm1
|
||||
return $ mkAbs vars trm3
|
||||
|
||||
where
|
||||
|
||||
globalTable = oElem showAll opts --- i -all
|
||||
|
||||
comp g t = ---- refreshTerm t >>=
|
||||
computeTerm gr g t
|
||||
|
||||
etaExpand su t = do
|
||||
t' <- comp su t
|
||||
case t' of
|
||||
R _ | rightType t' -> comp su t' --- return t' wo noexpand...
|
||||
_ -> recordExpand val t' >>= comp su
|
||||
-- don't eta expand records of right length (correct by type checking)
|
||||
rightType t = case (t,val) of
|
||||
(R rs, RecType ts) -> length rs == length ts
|
||||
_ -> False
|
||||
|
||||
outCase subst t = do
|
||||
pts <- getParams context
|
||||
let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
|
||||
if null args
|
||||
then return t
|
||||
else do
|
||||
let argtyp = RecType $ tuple2recordType ptyps
|
||||
let pvars = map (Vr . zIdent . prt) args -- gets eliminated
|
||||
patt <- term2patt $ R $ tuple2record $ pvars
|
||||
let t' = replace (zip args pvars) t
|
||||
t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
|
||||
return $ S t1 $ R $ tuple2record args
|
||||
|
||||
--- notice: this assumes that all lin types follow the "old JFP style"
|
||||
getParams = liftM concat . mapM getParam
|
||||
getParam (argv,RecType rs) = return
|
||||
[(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)]
|
||||
---getParam (_,ty) | ty==typeStr = return [] --- in lindef
|
||||
getParam (av,ty) =
|
||||
Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av)
|
||||
--- all lin types are rec types
|
||||
|
||||
replace :: [(Term,Term)] -> Term -> Term
|
||||
replace reps trm = case trm of
|
||||
-- this is the important case
|
||||
P _ _ -> maybe trm id $ lookup trm reps
|
||||
_ -> composSafeOp (replace reps) trm
|
||||
|
||||
occur t trm = case trm of
|
||||
|
||||
-- this is the important case
|
||||
P _ _ -> t == trm
|
||||
S x y -> occur t y || occur t x
|
||||
App f x -> occur t x || occur t f
|
||||
Abs _ f -> occur t f
|
||||
R rs -> any (occur t) (map (snd . snd) rs)
|
||||
T _ cs -> any (occur t) (map snd cs)
|
||||
C x y -> occur t x || occur t y
|
||||
Glue x y -> occur t x || occur t y
|
||||
ExtR x y -> occur t x || occur t y
|
||||
FV ts -> any (occur t) ts
|
||||
V _ ts -> any (occur t) ts
|
||||
Let (_,(_,x)) y -> occur t x || occur t y
|
||||
_ -> False
|
||||
|
||||
|
||||
-- here we must be careful not to reduce
|
||||
-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
|
||||
-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ;
|
||||
|
||||
recordExpand :: Type -> Term -> Err Term
|
||||
recordExpand typ trm = case unComputed typ of
|
||||
RecType tys -> case trm of
|
||||
FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
|
||||
_ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
|
||||
_ -> return trm
|
||||
|
||||
|
||||
-- | auxiliaries for compiling the resource
|
||||
|
||||
mkLinDefault :: SourceGrammar -> Type -> Err Term
|
||||
mkLinDefault gr typ = do
|
||||
case unComputed typ of
|
||||
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
|
||||
_ -> prtBad "linearization type must be a record type, not" typ
|
||||
where
|
||||
mkDefField typ = case unComputed typ of
|
||||
Table p t -> do
|
||||
t' <- mkDefField t
|
||||
let T _ cs = mkWildCases t'
|
||||
return $ T (TWild p) cs
|
||||
Sort "Str" -> return $ Vr strVar
|
||||
QC q p -> lookupFirstTag gr q p
|
||||
RecType r -> do
|
||||
let (ls,ts) = unzip r
|
||||
ts' <- mapM mkDefField ts
|
||||
return $ R $ [assign l t | (l,t) <- zip ls ts']
|
||||
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
|
||||
_ -> prtBad "linearization type field cannot be" typ
|
||||
|
||||
-- | Form the printname: if given, compute. If not, use the computed
|
||||
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
|
||||
--- We cannot use linearization at this stage, since we do not know the
|
||||
--- defaults we would need for question marks - and we're not yet in canon.
|
||||
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
|
||||
evalPrintname gr c ppr lin =
|
||||
case ppr of
|
||||
Yes pr -> comp pr
|
||||
_ -> case lin of
|
||||
Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
|
||||
_ -> return $ K $ prt c ----
|
||||
where
|
||||
comp = computeConcrete gr
|
||||
|
||||
oneBranch t = case t of
|
||||
Abs _ b -> oneBranch b
|
||||
R (r:_) -> oneBranch $ snd $ snd r
|
||||
T _ (c:_) -> oneBranch $ snd c
|
||||
V _ (c:_) -> oneBranch c
|
||||
FV (t:_) -> oneBranch t
|
||||
C x y -> C (oneBranch x) (oneBranch y)
|
||||
S x _ -> oneBranch x
|
||||
P x _ -> oneBranch x
|
||||
Alts (d,_) -> oneBranch d
|
||||
_ -> t
|
||||
|
||||
--- very unclean cleaner
|
||||
clean s = case s of
|
||||
'+':'+':' ':cs -> clean cs
|
||||
'"':cs -> clean cs
|
||||
c:cs -> c: clean cs
|
||||
_ -> s
|
||||
|
||||
-}
|
||||
3210
src-3.0/GF/Devel/Compile/ParGF.hs
Normal file
3210
src-3.0/GF/Devel/Compile/ParGF.hs
Normal file
File diff suppressed because one or more lines are too long
481
src-3.0/GF/Devel/Compile/PrintGF.hs
Normal file
481
src-3.0/GF/Devel/Compile/PrintGF.hs
Normal file
@@ -0,0 +1,481 @@
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module GF.Devel.Compile.PrintGF where
|
||||
|
||||
-- pretty-printer generated by the BNF converter
|
||||
|
||||
import GF.Devel.Compile.AbsGF
|
||||
import Char
|
||||
|
||||
-- the top-level printing method
|
||||
printTree :: Print a => a -> String
|
||||
printTree = render . prt 0
|
||||
|
||||
type Doc = [ShowS] -> [ShowS]
|
||||
|
||||
doc :: ShowS -> Doc
|
||||
doc = (:)
|
||||
|
||||
render :: Doc -> String
|
||||
render d = rend 0 (map ($ "") $ d []) "" where
|
||||
rend i ss = case ss of
|
||||
"[" :ts -> showChar '[' . rend i ts
|
||||
"(" :ts -> showChar '(' . rend i ts
|
||||
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
|
||||
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
|
||||
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
|
||||
";" :ts -> showChar ';' . new i . rend i ts
|
||||
t : "," :ts -> showString t . space "," . rend i ts
|
||||
t : ")" :ts -> showString t . showChar ')' . rend i ts
|
||||
t : "]" :ts -> showString t . showChar ']' . rend i ts
|
||||
t :ts -> space t . rend i ts
|
||||
_ -> id
|
||||
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
|
||||
space t = showString t . (\s -> if null s then "" else (' ':s))
|
||||
|
||||
parenth :: Doc -> Doc
|
||||
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
|
||||
|
||||
concatS :: [ShowS] -> ShowS
|
||||
concatS = foldr (.) id
|
||||
|
||||
concatD :: [Doc] -> Doc
|
||||
concatD = foldr (.) id
|
||||
|
||||
replicateS :: Int -> ShowS -> ShowS
|
||||
replicateS n f = concatS (replicate n f)
|
||||
|
||||
-- the printer class does the job
|
||||
class Print a where
|
||||
prt :: Int -> a -> Doc
|
||||
prtList :: [a] -> Doc
|
||||
prtList = concatD . map (prt 0)
|
||||
|
||||
instance Print a => Print [a] where
|
||||
prt _ = prtList
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
|
||||
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
|
||||
|
||||
mkEsc :: Char -> Char -> ShowS
|
||||
mkEsc q s = case s of
|
||||
_ | s == q -> showChar '\\' . showChar s
|
||||
'\\'-> showString "\\\\"
|
||||
'\n' -> showString "\\n"
|
||||
'\t' -> showString "\\t"
|
||||
_ -> showChar s
|
||||
|
||||
prPrec :: Int -> Int -> Doc -> Doc
|
||||
prPrec i j = if j<i then parenth else id
|
||||
|
||||
|
||||
instance Print Integer where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
instance Print Double where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
|
||||
instance Print PIdent where
|
||||
prt _ (PIdent (_,i)) = doc (showString i)
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
|
||||
instance Print LString where
|
||||
prt _ (LString i) = doc (showString i)
|
||||
|
||||
|
||||
|
||||
instance Print Grammar where
|
||||
prt i e = case e of
|
||||
Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs])
|
||||
|
||||
|
||||
instance Print ModDef where
|
||||
prt i e = case e of
|
||||
MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print ModType where
|
||||
prt i e = case e of
|
||||
MAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident])
|
||||
MResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident])
|
||||
MGrammar pident -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident])
|
||||
MInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident])
|
||||
MConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
|
||||
MInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
|
||||
|
||||
|
||||
instance Print ModBody where
|
||||
prt i e = case e of
|
||||
MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
|
||||
MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds])
|
||||
MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens])
|
||||
MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
|
||||
MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens])
|
||||
MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
|
||||
MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident])
|
||||
MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds])
|
||||
|
||||
|
||||
instance Print Extend where
|
||||
prt i e = case e of
|
||||
Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")])
|
||||
NoExt -> prPrec i 0 (concatD [])
|
||||
|
||||
|
||||
instance Print Opens where
|
||||
prt i e = case e of
|
||||
NoOpens -> prPrec i 0 (concatD [])
|
||||
OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")])
|
||||
|
||||
|
||||
instance Print Open where
|
||||
prt i e = case e of
|
||||
OName pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
OQual pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print ComplMod where
|
||||
prt i e = case e of
|
||||
CMCompl -> prPrec i 0 (concatD [])
|
||||
CMIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")])
|
||||
|
||||
|
||||
instance Print Included where
|
||||
prt i e = case e of
|
||||
IAll pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")])
|
||||
IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print TopDef where
|
||||
prt i e = case e of
|
||||
DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs])
|
||||
DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs])
|
||||
DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs])
|
||||
DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs])
|
||||
DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs])
|
||||
DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs])
|
||||
DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs])
|
||||
DefLincat defs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 defs])
|
||||
DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs])
|
||||
DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs])
|
||||
DefPrintCat defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 defs])
|
||||
DefPrintFun defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 defs])
|
||||
DefFlag defs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 defs])
|
||||
DefPrintOld defs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 defs])
|
||||
DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs])
|
||||
DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs])
|
||||
DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")])
|
||||
DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs])
|
||||
DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print Def where
|
||||
prt i e = case e of
|
||||
DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp])
|
||||
DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
|
||||
DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp])
|
||||
DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x , doc (showString ";")])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print FunDef where
|
||||
prt i e = case e of
|
||||
FDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x , doc (showString ";")])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print CatDef where
|
||||
prt i e = case e of
|
||||
SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
|
||||
ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")])
|
||||
ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x , doc (showString ";")])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print DataDef where
|
||||
prt i e = case e of
|
||||
DataDef name dataconstrs -> prPrec i 0 (concatD [prt 0 name , doc (showString "=") , prt 0 dataconstrs])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x , doc (showString ";")])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print DataConstr where
|
||||
prt i e = case e of
|
||||
DataId pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
|
||||
|
||||
instance Print ParDef where
|
||||
prt i e = case e of
|
||||
ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs])
|
||||
ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x , doc (showString ";")])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print ParConstr where
|
||||
prt i e = case e of
|
||||
ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
|
||||
|
||||
instance Print Name where
|
||||
prt i e = case e of
|
||||
PIdentName pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print LocDef where
|
||||
prt i e = case e of
|
||||
LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp])
|
||||
LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp])
|
||||
LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Exp where
|
||||
prt i e = case e of
|
||||
EPIdent pident -> prPrec i 6 (concatD [prt 0 pident])
|
||||
EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
|
||||
ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")])
|
||||
ESort sort -> prPrec i 6 (concatD [prt 0 sort])
|
||||
EString str -> prPrec i 6 (concatD [prt 0 str])
|
||||
EInt n -> prPrec i 6 (concatD [prt 0 n])
|
||||
EFloat d -> prPrec i 6 (concatD [prt 0 d])
|
||||
EMeta -> prPrec i 6 (concatD [doc (showString "?")])
|
||||
EEmpty -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")])
|
||||
EData -> prPrec i 6 (concatD [doc (showString "data")])
|
||||
EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")])
|
||||
EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
|
||||
ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")])
|
||||
ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")])
|
||||
EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")])
|
||||
ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")])
|
||||
EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label])
|
||||
EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")])
|
||||
EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
|
||||
EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp])
|
||||
ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
|
||||
ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
|
||||
EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
|
||||
ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
|
||||
EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
|
||||
EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])
|
||||
EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")])
|
||||
EPatt patt -> prPrec i 4 (concatD [doc (showString "pattern") , prt 2 patt])
|
||||
EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , doc (showString "type") , prt 5 exp])
|
||||
ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp])
|
||||
ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp])
|
||||
EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp])
|
||||
EGlue exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "+") , prt 1 exp])
|
||||
EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp])
|
||||
EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp])
|
||||
ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp])
|
||||
EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp])
|
||||
ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp])
|
||||
ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
|
||||
ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp])
|
||||
EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")])
|
||||
EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")])
|
||||
EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str])
|
||||
ELString lstring -> prPrec i 6 (concatD [prt 0 lstring])
|
||||
ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Exps where
|
||||
prt i e = case e of
|
||||
NilExp -> prPrec i 0 (concatD [])
|
||||
ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps])
|
||||
|
||||
|
||||
instance Print Patt where
|
||||
prt i e = case e of
|
||||
PChar -> prPrec i 2 (concatD [doc (showString "?")])
|
||||
PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
|
||||
PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident])
|
||||
PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
|
||||
PW -> prPrec i 2 (concatD [doc (showString "_")])
|
||||
PV pident -> prPrec i 2 (concatD [prt 0 pident])
|
||||
PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
|
||||
PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
|
||||
PInt n -> prPrec i 2 (concatD [prt 0 n])
|
||||
PFloat d -> prPrec i 2 (concatD [prt 0 d])
|
||||
PStr str -> prPrec i 2 (concatD [prt 0 str])
|
||||
PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")])
|
||||
PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")])
|
||||
PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts])
|
||||
PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts])
|
||||
PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt])
|
||||
PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt])
|
||||
PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")])
|
||||
PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt])
|
||||
PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 2 x])
|
||||
x:xs -> (concatD [prt 2 x , prt 0 xs])
|
||||
|
||||
instance Print PattAss where
|
||||
prt i e = case e of
|
||||
PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 patt])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Label where
|
||||
prt i e = case e of
|
||||
LPIdent pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
|
||||
|
||||
|
||||
instance Print Sort where
|
||||
prt i e = case e of
|
||||
Sort_Type -> prPrec i 0 (concatD [doc (showString "Type")])
|
||||
Sort_PType -> prPrec i 0 (concatD [doc (showString "PType")])
|
||||
Sort_Tok -> prPrec i 0 (concatD [doc (showString "Tok")])
|
||||
Sort_Str -> prPrec i 0 (concatD [doc (showString "Str")])
|
||||
Sort_Strs -> prPrec i 0 (concatD [doc (showString "Strs")])
|
||||
|
||||
|
||||
instance Print Bind where
|
||||
prt i e = case e of
|
||||
BPIdent pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
BWild -> prPrec i 0 (concatD [doc (showString "_")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print Decl where
|
||||
prt i e = case e of
|
||||
DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
|
||||
DExp exp -> prPrec i 0 (concatD [prt 4 exp])
|
||||
|
||||
|
||||
instance Print TupleComp where
|
||||
prt i e = case e of
|
||||
TComp exp -> prPrec i 0 (concatD [prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print PattTupleComp where
|
||||
prt i e = case e of
|
||||
PTComp patt -> prPrec i 0 (concatD [prt 0 patt])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print Case where
|
||||
prt i e = case e of
|
||||
Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Equation where
|
||||
prt i e = case e of
|
||||
Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , doc (showString "->") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Altern where
|
||||
prt i e = case e of
|
||||
Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print DDecl where
|
||||
prt i e = case e of
|
||||
DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
|
||||
DDExp exp -> prPrec i 0 (concatD [prt 6 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print OldGrammar where
|
||||
prt i e = case e of
|
||||
OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs])
|
||||
|
||||
|
||||
instance Print Include where
|
||||
prt i e = case e of
|
||||
NoIncl -> prPrec i 0 (concatD [])
|
||||
Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames])
|
||||
|
||||
|
||||
instance Print FileName where
|
||||
prt i e = case e of
|
||||
FString str -> prPrec i 0 (concatD [prt 0 str])
|
||||
FPIdent pident -> prPrec i 0 (concatD [prt 0 pident])
|
||||
FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename])
|
||||
FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename])
|
||||
FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename])
|
||||
FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concatD [prt 0 x , doc (showString ";")])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
|
||||
118
src-3.0/GF/Devel/Compile/Refresh.hs
Normal file
118
src-3.0/GF/Devel/Compile/Refresh.hs
Normal file
@@ -0,0 +1,118 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Refresh
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:27 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- make variable names unique by adding an integer index to each
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Compile.Refresh (
|
||||
refreshModule,
|
||||
refreshTerm,
|
||||
refreshTermN
|
||||
) where
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import GF.Devel.Grammar.Macros
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
|
||||
|
||||
-- for concrete and resource in grammar, before optimizing
|
||||
|
||||
refreshModule :: Int -> SourceModule -> Err (SourceModule,Int)
|
||||
refreshModule k (m,mo) = do
|
||||
(mo',(_,k')) <- appSTM (termOpModule refresh mo) (initIdStateN k)
|
||||
return ((m,mo'),k')
|
||||
|
||||
|
||||
refreshTerm :: Term -> Err Term
|
||||
refreshTerm = refreshTermN 0
|
||||
|
||||
refreshTermN :: Int -> Term -> Err Term
|
||||
refreshTermN i e = liftM snd $ refreshTermKN i e
|
||||
|
||||
refreshTermKN :: Int -> Term -> Err (Int,Term)
|
||||
refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $
|
||||
appSTM (refresh e) (initIdStateN i)
|
||||
|
||||
refresh :: Term -> STM IdState Term
|
||||
refresh e = case e of
|
||||
|
||||
Vr x -> liftM Vr (lookVar x)
|
||||
Abs x b -> liftM2 Abs (refVarPlus x) (refresh b)
|
||||
|
||||
Prod x a b -> do
|
||||
a' <- refresh a
|
||||
x' <- refVarPlus x
|
||||
b' <- refresh b
|
||||
return $ Prod x' a' b'
|
||||
|
||||
Let (x,(mt,a)) b -> do
|
||||
a' <- refresh a
|
||||
mt' <- case mt of
|
||||
Just t -> refresh t >>= (return . Just)
|
||||
_ -> return mt
|
||||
x' <- refVar x
|
||||
b' <- refresh b
|
||||
return (Let (x',(mt',a')) b')
|
||||
|
||||
R r -> liftM R $ refreshRecord r
|
||||
|
||||
ExtR r s -> liftM2 ExtR (refresh r) (refresh s)
|
||||
|
||||
T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
|
||||
|
||||
_ -> composOp refresh e
|
||||
|
||||
refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
|
||||
refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
|
||||
|
||||
refreshPatt p = case p of
|
||||
PV x -> liftM PV (refVarPlus x)
|
||||
PC c ps -> liftM (PC c) (mapM refreshPatt ps)
|
||||
PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
|
||||
PR r -> liftM PR (mapPairsM refreshPatt r)
|
||||
PT t p' -> liftM2 PT (refresh t) (refreshPatt p')
|
||||
|
||||
PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p')
|
||||
|
||||
PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q')
|
||||
PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q')
|
||||
PRep p' -> liftM PRep (refreshPatt p')
|
||||
PNeg p' -> liftM PNeg (refreshPatt p')
|
||||
|
||||
_ -> return p
|
||||
|
||||
refreshRecord r = case r of
|
||||
[] -> return r
|
||||
(x,(mt,a)):b -> do
|
||||
a' <- refresh a
|
||||
mt' <- case mt of
|
||||
Just t -> refresh t >>= (return . Just)
|
||||
_ -> return mt
|
||||
b' <- refreshRecord b
|
||||
return $ (x,(mt',a')) : b'
|
||||
|
||||
refreshTInfo i = case i of
|
||||
TTyped t -> liftM TTyped $ refresh t
|
||||
TComp t -> liftM TComp $ refresh t
|
||||
TWild t -> liftM TWild $ refresh t
|
||||
_ -> return i
|
||||
|
||||
-- for abstract syntax
|
||||
|
||||
refreshEquation :: Equation -> Err ([Patt],Term)
|
||||
refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
|
||||
refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
|
||||
|
||||
239
src-3.0/GF/Devel/Compile/Rename.hs
Normal file
239
src-3.0/GF/Devel/Compile/Rename.hs
Normal file
@@ -0,0 +1,239 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Rename
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/30 18:39:44 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.19 $
|
||||
--
|
||||
-- AR 14\/5\/2003
|
||||
-- The top-level function 'renameGrammar' does several things:
|
||||
--
|
||||
-- - extends each module symbol table by indirections to extended module
|
||||
--
|
||||
-- - changes unqualified and as-qualified imports to absolutely qualified
|
||||
--
|
||||
-- - goes through the definitions and resolves names
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Compile.Rename (
|
||||
renameModule
|
||||
) where
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import GF.Devel.Grammar.Macros
|
||||
import GF.Devel.Grammar.PrGF
|
||||
import GF.Infra.Ident
|
||||
import GF.Devel.Grammar.Lookup
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.Map as Map
|
||||
import Data.List (nub)
|
||||
import Debug.Trace (trace)
|
||||
|
||||
{-
|
||||
-- | this gives top-level access to renaming term input in the cc command
|
||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
|
||||
renameSourceTerm g m t = do
|
||||
mo <- lookupErr m (modules g)
|
||||
status <- buildStatus g m mo
|
||||
renameTerm status [] t
|
||||
-}
|
||||
|
||||
renameModule :: GF -> SourceModule -> Err SourceModule
|
||||
renameModule gf sm@(name,mo) = case mtype mo of
|
||||
MTInterface -> return sm
|
||||
_ | not (isCompleteModule mo) -> return sm
|
||||
_ -> errIn ("renaming module" +++ prt name) $ do
|
||||
let gf1 = gf {gfmodules = Map.insert name mo (gfmodules gf)}
|
||||
let rename = renameTerm (gf1,sm) []
|
||||
mo1 <- termOpModule rename mo
|
||||
let mo2 = mo1 {mopens = nub [(i,i) | (_,i) <- mopens mo1]}
|
||||
return (name,mo2)
|
||||
|
||||
type RenameEnv = (GF,SourceModule)
|
||||
|
||||
renameIdentTerm :: RenameEnv -> Term -> Err Term
|
||||
renameIdentTerm (gf, (name,mo)) trm = case trm of
|
||||
Vr i -> looks i
|
||||
Con i -> looks i
|
||||
Q m i -> getQualified m >>= look i
|
||||
QC m i -> getQualified m >>= look i
|
||||
_ -> return trm
|
||||
where
|
||||
looks i = do
|
||||
let ts = nub [t | m <- pool, Ok t <- [look i m]]
|
||||
case ts of
|
||||
[t] -> return t
|
||||
[] | elem i [IC "Int",IC "Float",IC "String"] -> ---- do this better
|
||||
return (Q (IC "PredefAbs") i)
|
||||
[] -> prtBad "identifier not found" i
|
||||
t:_ ->
|
||||
trace (unwords $ "WARNING":"identifier":prt i:"ambiguous:" : map prt ts)
|
||||
(return t)
|
||||
---- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts
|
||||
look i m = do
|
||||
ju <- lookupIdent gf m i
|
||||
return $ case jform ju of
|
||||
JLink -> if isConstructor ju then QC (jlink ju) i else Q (jlink ju) i
|
||||
_ -> if isConstructor ju then QC m i else Q m i
|
||||
pool = nub $ name :
|
||||
maybe name id (interfaceName mo) :
|
||||
IC "Predef" :
|
||||
map fst (mextends mo) ++
|
||||
map snd (mopens mo)
|
||||
getQualified m = case Map.lookup m qualifMap of
|
||||
Just n -> return n
|
||||
_ -> prtBad "unknown qualifier" m
|
||||
qualifMap = Map.fromList $
|
||||
mopens mo ++
|
||||
concat [ops | (_,ops) <- minstances mo] ++
|
||||
[(m,m) | m <- pool]
|
||||
---- TODO: check uniqueness of these names
|
||||
|
||||
renameTerm :: RenameEnv -> [Ident] -> Term -> Err Term
|
||||
renameTerm env vars = ren vars where
|
||||
ren vs trm = case trm of
|
||||
Abs x b -> liftM (Abs x) (ren (x:vs) b)
|
||||
Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
|
||||
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
|
||||
Vr x
|
||||
| elem x vs -> return trm
|
||||
| otherwise -> renid trm
|
||||
Con _ -> renid trm
|
||||
Q _ _ -> renid trm
|
||||
QC _ _ -> renid trm
|
||||
Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
|
||||
T i cs -> do
|
||||
i' <- case i of
|
||||
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
|
||||
_ -> return i
|
||||
liftM (T i') $ mapM (renCase vs) cs
|
||||
|
||||
Let (x,(m,a)) b -> do
|
||||
m' <- case m of
|
||||
Just ty -> liftM Just $ ren vs ty
|
||||
_ -> return m
|
||||
a' <- ren vs a
|
||||
b' <- ren (x:vs) b
|
||||
return $ Let (x,(m',a')) b'
|
||||
|
||||
P t@(Vr r) l -- for constant t we know it is projection
|
||||
| elem r vs -> return trm -- var proj first
|
||||
| otherwise -> case renid (Q r (label2ident l)) of -- qualif second
|
||||
Ok t -> return t
|
||||
_ -> case liftM (flip P l) $ renid t of
|
||||
Ok t -> return t -- const proj last
|
||||
_ -> prtBad "unknown qualified constant" trm
|
||||
|
||||
EPatt p -> do
|
||||
(p',_) <- renpatt p
|
||||
return $ EPatt p'
|
||||
|
||||
_ -> composOp (ren vs) trm
|
||||
|
||||
renid = renameIdentTerm env
|
||||
renCase vs (p,t) = do
|
||||
(p',vs') <- renpatt p
|
||||
t' <- ren (vs' ++ vs) t
|
||||
return (p',t')
|
||||
renpatt = renamePattern env
|
||||
|
||||
-- | vars not needed in env, since patterns always overshadow old vars
|
||||
renamePattern :: RenameEnv -> Patt -> Err (Patt,[Ident])
|
||||
renamePattern env patt = case patt of
|
||||
|
||||
PMacro c -> do
|
||||
c' <- renid $ Vr c
|
||||
case c' of
|
||||
Q p d -> renp $ PM p d
|
||||
_ -> prtBad "unresolved pattern" patt
|
||||
|
||||
PC c ps -> do
|
||||
c' <- renid $ Vr c
|
||||
case c' of
|
||||
QC p d -> renp $ PP p d ps
|
||||
Q p d -> renp $ PP p d ps
|
||||
_ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
|
||||
|
||||
PP p c ps -> do
|
||||
|
||||
(p', c') <- case renid (QC p c) of
|
||||
Ok (QC p' c') -> return (p',c')
|
||||
_ -> return (p,c) --- temporarily, for bw compat
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs) = unzip psvss
|
||||
return (PP p' c' ps', concat vs)
|
||||
|
||||
PV x -> case renid (Vr x) of
|
||||
Ok (QC m c) -> return (PP m c [],[])
|
||||
_ -> return (patt, [x])
|
||||
|
||||
PR r -> do
|
||||
let (ls,ps) = unzip r
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs') = unzip psvss
|
||||
return (PR (zip ls ps'), concat vs')
|
||||
|
||||
PAlt p q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PAlt p' q', vs ++ ws)
|
||||
|
||||
PSeq p q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PSeq p' q', vs ++ ws)
|
||||
|
||||
PRep p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PRep p', vs)
|
||||
|
||||
PNeg p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PNeg p', vs)
|
||||
|
||||
PAs x p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PAs x p', x:vs)
|
||||
|
||||
_ -> return (patt,[])
|
||||
|
||||
where
|
||||
renp = renamePattern env
|
||||
renid = renameIdentTerm env
|
||||
|
||||
renameParam :: RenameEnv -> (Ident, Context) -> Err (Ident, Context)
|
||||
renameParam env (c,co) = do
|
||||
co' <- renameContext env co
|
||||
return (c,co')
|
||||
|
||||
renameContext :: RenameEnv -> Context -> Err Context
|
||||
renameContext b = renc [] where
|
||||
renc vs cont = case cont of
|
||||
(x,t) : xts
|
||||
| isWildIdent x -> do
|
||||
t' <- ren vs t
|
||||
xts' <- renc vs xts
|
||||
return $ (x,t') : xts'
|
||||
| otherwise -> do
|
||||
t' <- ren vs t
|
||||
let vs' = x:vs
|
||||
xts' <- renc vs' xts
|
||||
return $ (x,t') : xts'
|
||||
_ -> return cont
|
||||
ren = renameTerm b
|
||||
|
||||
-- | vars not needed in env, since patterns always overshadow old vars
|
||||
renameEquation :: RenameEnv -> [Ident] -> Equation -> Err Equation
|
||||
renameEquation b vs (ps,t) = do
|
||||
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
|
||||
t' <- renameTerm b (concat vs' ++ vs) t
|
||||
return (ps',t')
|
||||
|
||||
679
src-3.0/GF/Devel/Compile/SourceToGF.hs
Normal file
679
src-3.0/GF/Devel/Compile/SourceToGF.hs
Normal file
@@ -0,0 +1,679 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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.Compile.SourceToGF (
|
||||
transGrammar,
|
||||
transModDef,
|
||||
transExp,
|
||||
---- transOldGrammar,
|
||||
---- transInclude,
|
||||
newReservedWords
|
||||
) where
|
||||
|
||||
import qualified GF.Devel.Grammar.Grammar as G
|
||||
import GF.Devel.Grammar.Construct
|
||||
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.Compile.AbsGF
|
||||
import GF.Devel.Compile.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 G.GF
|
||||
transGrammar x = case x of
|
||||
Gr moddefs -> do
|
||||
moddefs' <- mapM transModDef moddefs
|
||||
let mos = Map.fromList moddefs'
|
||||
return $ emptyGF {G.gfmodules = mos}
|
||||
|
||||
transModDef :: ModDef -> Err (Ident, G.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, G.MTAbstract, id')
|
||||
MGrammar id -> mkModRes id G.MTGrammar body
|
||||
MResource id -> mkModRes id G.MTGrammar body
|
||||
MConcrete id open -> do
|
||||
id' <- transIdent id
|
||||
open' <- transIdent open
|
||||
return (transCncDef, G.MTConcrete open', id')
|
||||
MInterface id -> mkModRes id G.MTInterface body
|
||||
MInstance id open -> do
|
||||
open' <- transIdent open
|
||||
mkModRes id (G.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,d) | Left ds <- defs0, (i,d) <- ds]
|
||||
let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
|
||||
return (id', G.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,d) | Left ds <- defs0, (i,d) <- ds]
|
||||
let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
|
||||
return (id', G.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,G.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, G.MInclude)
|
||||
transIncludedExt x = case x of
|
||||
IAll i -> liftM2 (,) (transIdent i) (return G.MIAll)
|
||||
ISome i ids -> liftM2 (,) (transIdent i) (liftM G.MIOnly $ mapM transIdent ids)
|
||||
IMinus i ids -> liftM2 (,) (transIdent i) (liftM G.MIExcept $ mapM transIdent ids)
|
||||
|
||||
transAbsDef :: TopDef -> Err (Either [(Ident,G.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, G.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 = mkProd (cont ++ genericReplicate size cd) lc
|
||||
nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData))
|
||||
constyp = 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,G.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
|
||||
_ -> return $ Left [] ----
|
||||
---- _ -> Bad $ "illegal definition form in resource" +++ printTree x
|
||||
where
|
||||
|
||||
mkParamDefs (p,pars) =
|
||||
if null pars
|
||||
then [(p,addJType M.meta0 (emptyJudgement G.JParam))] -- in an interface
|
||||
else (p,resParam p pars) : paramConstructors p pars
|
||||
|
||||
mkOverload (c,j) = case (G.jtype j, G.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,G.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]
|
||||
-}
|
||||
_ -> return $ Left [] ----
|
||||
---- _ -> 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 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
|
||||
|
||||
EPattType typ -> liftM G.EPattType (transExp typ)
|
||||
EPatt patt -> liftM G.EPatt (transPatt patt)
|
||||
|
||||
ELString (LString str) -> return $ G.K str
|
||||
---- ELin id -> liftM G.LiT $ transIdent id
|
||||
|
||||
EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
|
||||
EData -> return G.EData
|
||||
|
||||
_ -> 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
|
||||
PChar -> return G.PChar
|
||||
PChars s -> return $ G.PChars s
|
||||
PMacro c -> liftM G.PMacro $ transIdent c
|
||||
PM m c -> liftM2 G.PM (transIdent m) (transIdent c)
|
||||
PW -> return wildPatt
|
||||
PV (PIdent (_,"_")) -> return 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 (PIdent (_,"_")) -> return identW
|
||||
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)
|
||||
Reference in New Issue
Block a user