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

remove all files that aren't used in GF-3.0

Browse Source
This commit is contained in:
kr.angelov
2008-05-22 11:59:31 +00:00
parent 6394f3ccfb
commit df0c4f81fa
286 changed files with 21 additions and 53176 deletions
Download Patch File Download Diff File Expand all files Collapse all files

145
src-3.0/GF/Devel/AbsCompute.hs
View File

@@ -1,145 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : AbsCompute
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
-- computation in abstract syntax w.r.t. explicit definitions.
--
-- old GF computation; to be updated
-----------------------------------------------------------------------------
module GF.Devel.AbsCompute (LookDef,
compute,
computeAbsTerm,
computeAbsTermIn,
beta
) where
import GF.Data.Operations
import GF.Grammar.Abstract
import GF.Grammar.PrGrammar
import GF.Grammar.LookAbs
import GF.Devel.Compute
import Debug.Trace
import Data.List(intersperse)
import Control.Monad (liftM, liftM2)
-- for debugging
tracd m t = t
-- tracd = trace
compute :: GFCGrammar -> Exp -> Err Exp
compute = computeAbsTerm
computeAbsTerm :: GFCGrammar -> Exp -> Err Exp
computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
-- | a hack to make compute work on source grammar as well
type LookDef = Ident -> Ident -> Err (Maybe Term)
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
compt vv t = case t of
-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
-- Abs x b -> liftM (Abs x) (compt (x:vv) b)
_ -> do
let t' = beta vv t
(yy,f,aa) <- termForm t'
let vv' = yy ++ vv
aa' <- mapM (compt vv') aa
case look f of
Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $
case findMatch eqs aa' of
Ok (d,g) -> do
--- let (xs,ts) = unzip g
--- ts' <- alphaFreshAll vv' ts
let g' = g --- zip xs ts'
d' <- compt vv' $ substTerm vv' g' d
tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d'
_ -> tracd ("no match" +++ prt t') $
do
let v = mkApp f aa'
return $ mkAbs yy $ v
Just d -> tracd ("define" +++ prt t') $ do
da <- compt vv' $ mkApp d aa'
return $ mkAbs yy $ da
_ -> do
let t2 = mkAbs yy $ mkApp f aa'
tracd ("not defined" +++ prt_ t2) $ return t2
look t = case t of
(Q m f) -> case lookd m f of
Ok (Just EData) -> Nothing -- canonical --- should always be QC
Ok md -> md
_ -> Nothing
Eqs _ -> return t ---- for nested fn
_ -> Nothing
beta :: [Ident] -> Exp -> Exp
beta vv c = case c of
Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b)
App f a ->
let (a',f') = (beta vv a, beta vv f) in
case f' of
Abs x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b)
_ -> (if a'==a && f'==f then id else beta vv) $ App f' a'
Prod x a b -> Prod x (beta vv a) (beta (x:vv) b)
Abs x b -> Abs x (beta (x:vv) b)
_ -> c
-- special version of pattern matching, to deal with comp under lambda
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
(patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
tryMatch (p,t) = do
t' <- termForm t
trym p t'
where
trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ----
case (p,t') of
(PV IW, _) | notMeta t -> return [] -- optimization with wildcard
(PV x, _) | notMeta t -> return [(x,t)]
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PP q p pp, ([], QC r f, tt)) |
p `eqStrIdent` f && length pp == length tt -> do
matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP q p pp, ([], Q r f, tt)) |
p `eqStrIdent` f && length pp == length tt -> do
matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PT _ p',_) -> trym p' t'
(_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
(PAs x p',_) -> do
subst <- trym p' t'
return $ (x,t) : subst
_ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t)
notMeta e = case e of
Meta _ -> False
App f a -> notMeta f && notMeta a
Abs _ b -> notMeta b
_ -> True
prtm p g =
prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g]

4
src-3.0/GF/Devel/CheckGrammar.hs
View File

@@ -256,7 +256,7 @@ checkCncInfo gr m (a,abs) (c,info) = do
case info of
CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do
typ <- checkErr $ lookupFunTypeSrc gr a c
typ <- checkErr $ lookupFunType gr a c
cat0 <- checkErr $ valCat typ
(cont,val) <- linTypeOfType gr m typ -- creates arg vars
(trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars
@@ -266,7 +266,7 @@ checkCncInfo gr m (a,abs) (c,info) = do
-- cat for cf, typ for pe
CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do
checkErr $ lookupCatContextSrc gr a c
checkErr $ lookupCatContext gr a c
typ' <- checkIfLinType gr typ
mdef' <- case mdef of
Yes def -> do

89
src-3.0/GF/Devel/CheckM.hs
View File

@@ -1,89 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CheckM
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:33 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Devel.CheckM (Check,
checkError, checkCond, checkWarn, checkUpdate, checkInContext,
checkUpdates, checkReset, checkResets, checkGetContext,
checkLookup, checkStart, checkErr, checkVal, checkIn,
prtFail
) where
import GF.Data.Operations
import GF.Devel.Grammar.Grammar
import GF.Infra.Ident
import GF.Devel.Grammar.PrGF
-- | the strings are non-fatal warnings
type Check a = STM (Context,[String]) a
checkError :: String -> Check a
checkError = raise
checkCond :: String -> Bool -> Check ()
checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end
checkWarn :: String -> Check ()
checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg))
checkUpdate :: Decl -> Check ()
checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))
checkInContext :: [Decl] -> Check r -> Check r
checkInContext g ch = do
i <- checkUpdates g
r <- ch
checkResets i
return r
checkUpdates :: [Decl] -> Check Int
checkUpdates ds = mapM checkUpdate ds >> return (length ds)
checkReset :: Check ()
checkReset = checkResets 1
checkResets :: Int -> Check ()
checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg))
checkGetContext :: Check Context
checkGetContext = do
(co,_) <- readSTM
return co
checkLookup :: Ident -> Check Type
checkLookup x = do
co <- checkGetContext
checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co
checkStart :: Check a -> Err (a,(Context,[String]))
checkStart c = appSTM c ([],[])
checkErr :: Err a -> Check a
checkErr e = stm (\s -> do
v <- e
return (v,s)
)
checkVal :: a -> Check a
checkVal v = return v
prtFail :: Print a => String -> a -> Check b
prtFail s t = checkErr $ prtBad s t
checkIn :: String -> Check a -> Check a
checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of
Bad e -> Bad $ msg ++++ e
Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where
new = take (length ws' - length ws) ws'
ws2 = [msg ++++ w | w <- new] ++ ws

274
src-3.0/GF/Devel/Compile/AbsGF.hs
View File

@@ -1,274 +0,0 @@
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
View File

File diff suppressed because it is too large Load Diff

205
src-3.0/GF/Devel/Compile/Compile.hs
View File

@@ -1,205 +0,0 @@
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
View File

@@ -1,26 +0,0 @@
-- 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
View File

@@ -1,154 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
View File

@@ -1,251 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
View File

@@ -1,326 +0,0 @@
-- AR 2/5/2003, 14-16 o'clock, Torino
-- 17/6/2007: marked with suffix --% those lines that are obsolete and
-- should not be included in documentation
entrypoints Grammar, ModDef,
OldGrammar, --%
Exp ; -- let's see if more are needed
comment "--" ;
comment "{-" "-}" ;
-- identifiers
position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ;
-- the top-level grammar
Gr. Grammar ::= [ModDef] ;
-- semicolon after module is permitted but not obligatory
terminator ModDef "" ;
_. ModDef ::= ModDef ";" ;
-- the individual modules
MModule. ModDef ::= ComplMod ModType "=" ModBody ;
MAbstract. ModType ::= "abstract" PIdent ;
MResource. ModType ::= "resource" PIdent ;
MGrammar. ModType ::= "grammar" PIdent ;
MInterface. ModType ::= "interface" PIdent ;
MConcrete. ModType ::= "concrete" PIdent "of" PIdent ;
MInstance. ModType ::= "instance" PIdent "of" PIdent ;
MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ;
MNoBody. ModBody ::= [Included] ;
MWith. ModBody ::= Included "with" [Open] ;
MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MWithE. ModBody ::= [Included] "**" Included "with" [Open] ;
MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MReuse. ModBody ::= "reuse" PIdent ; --%
MUnion. ModBody ::= "union" [Included] ;--%
separator TopDef "" ;
Ext. Extend ::= [Included] "**" ;
NoExt. Extend ::= ;
separator Open "," ;
NoOpens. Opens ::= ;
OpenIn. Opens ::= "open" [Open] "in" ;
OName. Open ::= PIdent ;
-- OQualQO. Open ::= "(" PIdent ")" ; --%
OQual. Open ::= "(" PIdent "=" PIdent ")" ;
CMCompl. ComplMod ::= ;
CMIncompl. ComplMod ::= "incomplete" ;
separator Included "," ;
IAll. Included ::= PIdent ;
ISome. Included ::= PIdent "[" [PIdent] "]" ;
IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ;
-- top-level definitions
DefCat. TopDef ::= "cat" [CatDef] ;
DefFun. TopDef ::= "fun" [FunDef] ;
DefFunData.TopDef ::= "data" [FunDef] ;
DefDef. TopDef ::= "def" [Def] ;
DefData. TopDef ::= "data" [DataDef] ;
DefPar. TopDef ::= "param" [ParDef] ;
DefOper. TopDef ::= "oper" [Def] ;
DefLincat. TopDef ::= "lincat" [Def] ;
DefLindef. TopDef ::= "lindef" [Def] ;
DefLin. TopDef ::= "lin" [Def] ;
DefPrintCat. TopDef ::= "printname" "cat" [Def] ;
DefPrintFun. TopDef ::= "printname" "fun" [Def] ;
DefFlag. TopDef ::= "flags" [Def] ;
-- definitions after most keywords
DDecl. Def ::= [Name] ":" Exp ;
DDef. Def ::= [Name] "=" Exp ;
DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list
DFull. Def ::= [Name] ":" Exp "=" Exp ;
FDecl. FunDef ::= [Name] ":" Exp ;
SimpleCatDef. CatDef ::= PIdent [DDecl] ;
ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ;
ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ;
DataDef. DataDef ::= Name "=" [DataConstr] ;
DataId. DataConstr ::= PIdent ;
DataQId. DataConstr ::= PIdent "." PIdent ;
separator DataConstr "|" ;
ParDefDir. ParDef ::= PIdent "=" [ParConstr] ;
ParDefAbs. ParDef ::= PIdent ;
ParConstr. ParConstr ::= PIdent [DDecl] ;
terminator nonempty Def ";" ;
terminator nonempty FunDef ";" ;
terminator nonempty CatDef ";" ;
terminator nonempty DataDef ";" ;
terminator nonempty ParDef ";" ;
separator ParConstr "|" ;
separator nonempty PIdent "," ;
-- names of categories and functions in definition LHS
PIdentName. Name ::= PIdent ;
ListName. Name ::= "[" PIdent "]" ;
separator nonempty Name "," ;
-- definitions in records and $let$ expressions
LDDecl. LocDef ::= [PIdent] ":" Exp ;
LDDef. LocDef ::= [PIdent] "=" Exp ;
LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ;
separator LocDef ";" ;
-- terms and types
EPIdent. Exp6 ::= PIdent ;
EConstr. Exp6 ::= "{" PIdent "}" ;--%
ECons. Exp6 ::= "%" PIdent "%" ;--%
ESort. Exp6 ::= Sort ;
EString. Exp6 ::= String ;
EInt. Exp6 ::= Integer ;
EFloat. Exp6 ::= Double ;
EMeta. Exp6 ::= "?" ;
EEmpty. Exp6 ::= "[" "]" ;
EData. Exp6 ::= "data" ;
EList. Exp6 ::= "[" PIdent Exps "]" ;
EStrings. Exp6 ::= "[" String "]" ;
ERecord. Exp6 ::= "{" [LocDef] "}" ; -- !
ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator ","
EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --%
ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations
EProj. Exp5 ::= Exp5 "." Label ;
EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --%
EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --%
EApp. Exp4 ::= Exp4 Exp5 ;
ETable. Exp4 ::= "table" "{" [Case] "}" ;
ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ;
EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; --%
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
View File

@@ -1,72 +0,0 @@
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
View File

@@ -1,542 +0,0 @@
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
View File

@@ -1,56 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
View File

File diff suppressed because one or more lines are too long

333
src-3.0/GF/Devel/Compile/Optimize.hs
View File

@@ -1,333 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
View File

File diff suppressed because one or more lines are too long

481
src-3.0/GF/Devel/Compile/PrintGF.hs
View File

@@ -1,481 +0,0 @@
{-# 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
View File

@@ -1,118 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
View File

@@ -1,239 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
View File

@@ -1,679 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : SourceToGF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/04 11:05:07 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.28 $
--
-- based on the skeleton Haskell module generated by the BNF converter
-----------------------------------------------------------------------------
module GF.Devel.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 (identV "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)

28
src-3.0/GF/Devel/GFC/Main.hs
View File

@@ -1,28 +0,0 @@
module GF.Devel.GFC.Main where
import GF.Devel.GFC.Options
import System.Environment
import System.Exit
import System.IO
version = "X.X"
main :: IO ()
main =
do args <- getArgs
case parseOptions args of
Ok (opts, files) ->
case optMode opts of
Version -> putStrLn $ "GF, version " ++ version
Help -> putStr helpMessage
Compiler -> gfcMain opts files
Errors errs ->
do mapM_ (hPutStrLn stderr) errs
exitFailure
gfcMain :: Options -> [FilePath] -> IO ()
gfcMain opts files = return ()

28
src-3.0/GF/Devel/GFCCInterpreter.hs
View File

@@ -1,28 +0,0 @@
module Main where
import GF.Command.Interpreter
import GF.Command.Commands
import GF.GFCC.API
import System (getArgs)
import Data.Char (isDigit)
-- Simple translation application built on GFCC. AR 7/9/2006 -- 19/9/2007
main :: IO ()
main = do
file:_ <- getArgs
grammar <- file2grammar file
let env = CommandEnv grammar (allCommands grammar)
printHelp grammar
loop env
loop :: CommandEnv -> IO ()
loop env = do
s <- getLine
if s == "q" then return () else do
interpretCommandLine env s
loop env
printHelp grammar = do
putStrLn $ "languages: " ++ unwords (languages grammar)
putStrLn $ "categories: " ++ unwords (categories grammar)

166
src-3.0/GF/Devel/Grammar/AppPredefined.hs
View File

@@ -1,166 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : AppPredefined
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/06 14:21:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
module GF.Devel.Grammar.AppPredefined (
isInPredefined,
typPredefined,
appPredefined
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF (prt,prt_,prtBad)
import GF.Infra.Ident
import GF.Data.Operations
-- predefined function type signatures and definitions. AR 12/3/2003.
isInPredefined :: Ident -> Bool
isInPredefined = err (const True) (const False) . typPredefined
typPredefined :: Ident -> Err Type
typPredefined c@(IC f) = case f of
"Int" -> return typePType
"Float" -> return typePType
"Error" -> return typeType
"Ints" -> return $ mkFunType [cnPredef "Int"] typePType
"PBool" -> return typePType
"error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set
"PFalse" -> return $ cnPredef "PBool"
"PTrue" -> return $ cnPredef "PBool"
"dp" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
"drop" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
"eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"eqStr" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
"length" -> return $ mkFunType [typeStr] (cnPredef "Int")
"occur" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
"occurs" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
"plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
---- "read" -> (P : Type) -> Tok -> P
"show" -> return $ mkProds -- (P : PType) -> P -> Tok
([(identC "P",typePType),(identW,Vr (identC "P"))],typeStr,[])
"toStr" -> return $ mkProds -- (L : Type) -> L -> Str
([(identC "L",typeType),(identW,Vr (identC "L"))],typeStr,[])
"mapStr" ->
let ty = identC "L" in
return $ mkProds -- (L : Type) -> (Str -> Str) -> L -> L
([(ty,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr ty)],Vr ty,[])
"take" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
"tk" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
_ -> prtBad "unknown in Predef:" c
typPredefined c = prtBad "unknown in Predef:" c
mkProds (cont,t,xx) = foldr (uncurry Prod) (mkApp t xx) cont
appPredefined :: Term -> Err (Term,Bool)
appPredefined t = case t of
App f x0 -> do
(x,_) <- appPredefined x0
case f of
-- one-place functions
Q (IC "Predef") (IC f) -> case (f, x) of
("length", K s) -> retb $ EInt $ toInteger $ length s
_ -> retb t ---- prtBad "cannot compute predefined" t
-- two-place functions
App (Q (IC "Predef") (IC f)) z0 -> do
(z,_) <- appPredefined z0
case (f, norm z, norm x) of
("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
("take", EInt i, K s) -> retb $ K (take (fi i) s)
("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse
("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse
("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
("plus", EInt i, EInt j) -> retb $ EInt $ i+j
("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
("toStr", _, t) -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t
-- three-place functions
App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
(y,_) <- appPredefined y0
(z,_) <- appPredefined z0
case (f, z, y, x) of
("mapStr",ty,op,t) -> retf $ mapStr ty op t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t
---- should really check the absence of arg variables
where
retb t = return (t,True) -- no further computing needed
retf t = return (t,False) -- must be computed further
norm t = case t of
Empty -> K []
_ -> t
fi = fromInteger
-- read makes variables into constants
str2tag :: String -> Term
str2tag s = case s of
---- '\'' : cs -> mkCn $ pTrm $ init cs
_ -> Con $ IC s ---
where
mkCn t = case t of
Vr i -> Con i
App c a -> App (mkCn c) (mkCn a)
_ -> t
predefTrue = Q (IC "Predef") (IC "PTrue")
predefFalse = Q (IC "Predef") (IC "PFalse")
substring :: String -> String -> Bool
substring s t = case (s,t) of
(c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
([],_) -> True
_ -> False
trm2str :: Term -> Err Term
trm2str t = case t of
R ((_,(_,s)):_) -> trm2str s
T _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s
C _ _ -> return $ t
K _ -> return $ t
S c _ -> trm2str c
Empty -> return $ t
_ -> prtBad "cannot get Str from term" t
-- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated
-- (this has been done in type checking)
mapStr :: Type -> Term -> Term -> Term
mapStr ty f t = case (ty,t) of
_ | elem ty [typeStr,typeStr] -> App f t
(_, R ts) -> R [(l,mapField v) | (l,v) <- ts]
(Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
_ -> t
where
mapField (mty,te) = case mty of
Just ty -> (mty,mapStr ty f te)
_ -> (mty,te)

380
src-3.0/GF/Devel/Grammar/Compute.hs
View File

@@ -1,380 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Compute
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/01 15:39:12 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
-- Computation of source terms. Used in compilation and in @cc@ command.
-----------------------------------------------------------------------------
module GF.Devel.Grammar.Compute (
computeTerm,
computeTermCont,
computeTermRec
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Lookup
import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.PatternMatch
import GF.Devel.Grammar.AppPredefined
import GF.Infra.Ident
import GF.Infra.Option
--import GF.Grammar.Refresh
--import GF.Grammar.Lockfield (isLockLabel) ----
import GF.Data.Str ----
import GF.Data.Operations
import Data.List (nub,intersperse)
import Control.Monad (liftM2, liftM)
-- | computation of concrete syntax terms into normal form
-- used mainly for partial evaluation
computeTerm :: GF -> Term -> Err Term
computeTerm g t = {- refreshTerm t >>= -} computeTermCont g [] t
computeTermRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t
computeTermCont :: GF -> Substitution -> Term -> Err Term
computeTermCont = computeTermOpt False
-- rec=True is used if it cannot be assumed that looked-up constants
-- have already been computed (mainly with -optimize=noexpand in .gfr)
computeTermOpt :: Bool -> GF -> Substitution -> Term -> Err Term
computeTermOpt rec gr = comp where
comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
case t of
Q (IC "Predef") _ -> return t
Q p c -> look p c
-- if computed do nothing
---- Computed t' -> return $ unComputed t'
Vr x -> do
t' <- maybe (prtBad ("no value for variable") x) return $ lookup x g
case t' of
_ | t == t' -> return t
_ -> comp g t'
Abs x b -> do
b' <- comp (ext x (Vr x) g) b
return $ Abs x b'
Let (x,(_,a)) b -> do
a' <- comp g a
comp (ext x a' g) b
Prod x a b -> do
a' <- comp g a
b' <- comp (ext x (Vr x) g) b
return $ Prod x a' b'
-- beta-convert
App f a -> do
f' <- comp g f
a' <- comp g a
case (f',a') of
(Abs x b, FV as) ->
mapM (\c -> comp (ext x c g) b) as >>= return . variants
(_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
(Abs x b,_) -> comp (ext x a' g) b
(QC _ _,_) -> returnC $ App f' a'
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
(S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
_ -> do
(t',b) <- appPredefined (App f' a')
if b then return t' else comp g t'
P t l -> do
t' <- comp g t
case t' of
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
R r -> maybe (prtBad "no value for label" l) (comp g . snd) $
lookup l $ reverse r
ExtR a (R b) ->
case comp g (P (R b) l) of
Ok v -> return v
_ -> comp g (P a l)
--- { - --- this is incorrect, since b can contain the proper value
ExtR (R a) b -> -- NOT POSSIBLE both a and b records!
case comp g (P (R a) l) of
Ok v -> return v
_ -> comp g (P b l)
--- - } ---
S (T i cs) e -> prawitz g i (flip P l) cs e
S (V i cs) e -> prawitzV g i (flip P l) cs e
_ -> returnC $ P t' l
PI t l i -> comp g $ P t l -----
S t@(T ti cc) v -> do
v' <- comp g v
case v' of
FV vs -> do
ts' <- mapM (comp g . S t) vs
return $ variants ts'
_ -> case ti of
{-
TComp _ -> do
case term2patt v' of
Ok p' -> case lookup p' cc of
Just u -> comp g u
_ -> do
t' <- comp g t
return $ S t' v' -- if v' is not canonical
_ -> do
t' <- comp g t
return $ S t' v'
-}
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
_ -> do
t' <- comp g t
return $ S t' v' -- if v' is not canonical
S t v -> do
t' <- case t of
---- why not? ResFin.Agr "has no values"
---- T (TComp _) _ -> return t
---- V _ _ -> return t
_ -> comp g t
v' <- comp g v
case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
_ -> case t' of
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
T _ [(PV IW,c)] -> comp g c --- an optimization
T _ [(PT _ (PV IW),c)] -> comp g c
T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
-- course-of-values table: look up by index, no pattern matching needed
V ptyp ts -> do
vs <- allParamValues gr ptyp
case lookup v' (zip vs [0 .. length vs - 1]) of
Just i -> comp g $ ts !! i
----- _ -> prtBad "selection" $ S t' v' -- debug
_ -> return $ S t' v' -- if v' is not canonical
T (TComp _) cs -> do
case term2patt v' of
Ok p' -> case lookup p' cs of
Just u -> comp g u
_ -> return $ S t' v' -- if v' is not canonical
_ -> return $ S t' v'
T _ cc -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical
S (T i cs) e -> prawitz g i (flip S v') cs e
S (V i cs) e -> prawitzV g i (flip S v') cs e
_ -> returnC $ S t' v'
-- normalize away empty tokens
K "" -> return Empty
-- glue if you can
Glue x0 y0 -> do
x <- comp g x0
y <- comp g y0
case (x,y) of
(FV ks,_) -> do
kys <- mapM (comp g . flip Glue y) ks
return $ variants kys
(_,FV ks) -> do
xks <- mapM (comp g . Glue x) ks
return $ variants xks
(S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
(s, S (T i cs) e) -> prawitz g i (Glue s) cs e
(S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
(s, S (V i cs) e) -> prawitzV g i (Glue s) cs e
(_,Empty) -> return x
(Empty,_) -> return y
(K a, K b) -> return $ K (a ++ b)
(_, Alts (d,vs)) -> do
---- (K a, Alts (d,vs)) -> do
let glx = Glue x
comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
(Alts _, ka) -> checks [do
y' <- strsFromTerm ka
---- (Alts _, K a) -> checks [do
x' <- strsFromTerm x -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
,return $ Glue x y
]
(C u v,_) -> comp g $ C u (Glue v y)
_ -> do
mapM_ checkNoArgVars [x,y]
r <- composOp (comp g) t
returnC r
Alts _ -> do
r <- composOp (comp g) t
returnC r
-- remove empty
C a b -> do
a' <- comp g a
b' <- comp g b
case (a',b') of
(Alts _, K a) -> checks [do
as <- strsFromTerm a' -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
,
return $ C a' b'
]
(Empty,_) -> returnC b'
(_,Empty) -> returnC a'
_ -> returnC $ C a' b'
-- reduce free variation as much as you can
FV ts -> mapM (comp g) ts >>= returnC . variants
-- merge record extensions if you can
ExtR r s -> do
r' <- comp g r
s' <- comp g s
case (r',s') of
(R rs, R ss) -> plusRecord r' s'
(RecType rs, RecType ss) -> plusRecType r' s'
_ -> return $ ExtR r' s'
-- case-expand tables
-- if already expanded, don't expand again
T i@(TComp ty) cs -> do
-- if there are no variables, don't even go inside
cs' <- if (null g) then return cs else mapPairsM (comp g) cs
---- return $ V ty (map snd cs')
return $ T i cs'
T i cs -> do
pty0 <- errIn (prt t) $ getTableType i
ptyp <- comp g pty0
case allParamValues gr ptyp of
Ok vs -> do
cs' <- mapM (compBranchOpt g) cs ---- why is this needed??
sts <- mapM (matchPattern cs') vs
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- mapM term2patt vs
let ps' = ps --- PT ptyp (head ps) : tail ps
---- return $ V ptyp ts -- to save space ---- why doesn't this work??
return $ T (TComp ptyp) (zip ps' ts)
_ -> do
cs' <- mapM (compBranch g) cs
return $ T i cs' -- happens with variable types
-- otherwise go ahead
_ -> composOp (comp g) t >>= returnC
where
look p c
| rec = lookupOperDef gr p c >>= comp []
| otherwise = lookupOperDef gr p c
{-
look p c = case lookupResDefKind gr p c of
Ok (t,_) | noExpand p || rec -> comp [] t
Ok (t,_) -> return t
Bad s -> raise s
noExpand p = errVal False $ do
mo <- lookupModMod gr p
return $ case getOptVal (iOpts (flags mo)) useOptimizer of
Just "noexpand" -> True
_ -> False
-}
ext x a g = (x,a):g
returnC = return --- . computed
variants ts = case nub ts of
[t] -> t
ts -> FV ts
isCan v = case v of
Con _ -> True
QC _ _ -> True
App f a -> isCan f && isCan a
R rs -> all (isCan . snd . snd) rs
_ -> False
compBranch g (p,v) = do
let g' = contP p ++ g
v' <- comp g' v
return (p,v')
compBranchOpt g c@(p,v) = case contP p of
[] -> return c
_ -> err (const (return c)) return $ compBranch g c
contP p = case p of
PV x -> [(x,Vr x)]
PC _ ps -> concatMap contP ps
PP _ _ ps -> concatMap contP ps
PT _ p -> contP p
PR rs -> concatMap (contP . snd) rs
PAs x p -> (x,Vr x) : contP p
PSeq p q -> concatMap contP [p,q]
PAlt p q -> concatMap contP [p,q]
PRep p -> contP p
PNeg p -> contP p
_ -> []
prawitz g i f cs e = do
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
return $ S (T i cs') e
prawitzV g i f cs e = do
cs' <- mapM (comp g) [(f v) | v <- cs]
return $ S (V i cs') e
-- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term
checkNoArgVars t = case t of
Vr (IA _) -> Bad $ glueErrorMsg $ prt t
Vr (IAV _) -> Bad $ glueErrorMsg $ prt t
_ -> composOp checkNoArgVars t
glueErrorMsg s =
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
"Use Prelude.bind instead."

221
src-3.0/GF/Devel/Grammar/Construct.hs
View File

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

223
src-3.0/GF/Devel/Grammar/GFtoSource.hs
View File

@@ -1,223 +0,0 @@
module GF.Devel.Grammar.GFtoSource (
trGrammar,
trModule,
trAnyDef,
trLabel,
trt,
tri,
trp
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros (contextOfType)
import qualified GF.Devel.Compile.AbsGF as P
import GF.Infra.Ident
import GF.Data.Operations
import qualified Data.Map as Map
-- From internal source syntax to BNFC-generated (used for printing).
-- | AR 13\/5\/2003
--
-- translate internal to parsable and printable source
trGrammar :: GF -> P.Grammar
trGrammar = P.Gr . map trModule . listModules -- no includes
trModule :: (Ident,Module) -> P.ModDef
trModule (i,mo) = P.MModule compl typ body where
compl = case isCompleteModule mo of
False -> P.CMIncompl
_ -> P.CMCompl
i' = tri i
typ = case mtype mo of
MTGrammar -> P.MGrammar i'
MTAbstract -> P.MAbstract i'
MTConcrete a -> P.MConcrete i' (tri a)
MTInterface -> P.MInterface i'
MTInstance a -> P.MInstance i' (tri a)
body = P.MBody
(trExtends (mextends mo))
(mkOpens (map trOpen (mopens mo)))
(concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++
map trFlag (Map.assocs (mflags mo)))
trExtends :: [(Ident,MInclude)] -> P.Extend
trExtends [] = P.NoExt
trExtends es = (P.Ext $ map tre es) where
tre (i,c) = case c of
MIAll -> P.IAll (tri i)
MIOnly is -> P.ISome (tri i) (map tri is)
MIExcept is -> P.IMinus (tri i) (map tri is)
trOpen :: (Ident,Ident) -> P.Open
trOpen (i,j) = P.OQual (tri i) (tri j)
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
trAnyDef :: (Ident,Judgement) -> [P.TopDef]
trAnyDef (i,ju) = let
i' = mkName i
i0 = tri i
in case jform ju of
JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]]
JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]]
---- ++ case pt of
---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
---- _ -> []
---- JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
JParam -> [P.DefPar [
P.ParDefDir i0 [
P.ParConstr (tri c) (map trDecl co) | let EParam _ cos = jdef ju, (c,co) <- cos]
]]
JOper -> case jdef ju of
Overload tysts ->
[P.DefOper [P.DDef [i'] (
P.EApp (P.EPIdent $ ppIdent "overload")
(P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
tr -> [P.DefOper [trDef i (jtype ju) tr]]
JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]]
---- CncCat pty ptr ppr ->
---- [P.DefLindef [trDef i' pty ptr]]
---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
JLin ->
[P.DefLin [trDef i (Meta 0) (jdef ju)]]
---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
JLink -> []
trDef :: Ident -> Type -> Term -> P.Def
trDef i pty ptr = case (pty,ptr) of
(Meta _, Meta _) -> P.DDef [mkName i] (P.EMeta) ---
(_, Meta _) -> P.DDecl [mkName i] (trPerh pty)
(Meta _, _) -> P.DDef [mkName i] (trPerh ptr)
(_, _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
trPerh p = case p of
Meta _ -> P.EMeta
_ -> trt p
trFlag :: (Ident,String) -> P.TopDef
trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)]
trt :: Term -> P.Exp
trt trm = case trm of
Vr s -> P.EPIdent $ tri s
---- Cn s -> P.ECons $ tri s
Con s -> P.EConstr $ tri s
Sort s -> P.ESort $ case s of
"Type" -> P.Sort_Type
"PType" -> P.Sort_PType
"Tok" -> P.Sort_Tok
"Str" -> P.Sort_Str
"Strs" -> P.Sort_Strs
_ -> error $ "not yet sort " +++ show trm ----
App c a -> P.EApp (trt c) (trt a)
Abs x b -> P.EAbstr [trb x] (trt b)
Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
Meta m -> P.EMeta
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
Example t s -> P.EExample (trt t) s
R [] -> P.ETuple [] --- to get correct parsing when read back
R r -> P.ERecord $ map trAssign r
RecType r -> P.ERecord $ map trLabelling r
ExtR x y -> P.EExtend (trt x) (trt y)
P t l -> P.EProj (trt t) (trLabel l)
PI t l _ -> P.EProj (trt t) (trLabel l)
Q t l -> P.EQCons (tri t) (tri l)
QC t l -> P.EQConstr (tri t) (tri l)
T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
T _ cc -> P.ETable (map trCase cc)
V ty cc -> P.EVTable (trt ty) (map trt cc)
Typed tr ty -> P.ETyped (trt tr) (trt ty)
Table x v -> P.ETType (trt x) (trt v)
S f x -> P.ESelect (trt f) (trt x)
Let (x,(ma,b)) t ->
P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t)
where
b' = trt b
x' = [tri x]
Empty -> P.EEmpty
K [] -> P.EEmpty
K a -> P.EString a
C a b -> P.EConcat (trt a) (trt b)
EInt i -> P.EInt i
EFloat i -> P.EFloat i
EPatt p -> P.EPatt (trp p)
EPattType t -> P.EPattType (trt t)
Glue a b -> P.EGlue (trt a) (trt b)
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
FV ts -> P.EVariants $ map trt ts
EData -> P.EData
EParam t _ -> trt t
_ -> error $ "not yet" +++ show trm ----
trp :: Patt -> P.Patt
trp p = case p of
PChar -> P.PChar
PChars s -> P.PChars s
PM m c -> P.PM (tri m) (tri c)
PW -> P.PW
PV s | isWildIdent s -> P.PW
PV s -> P.PV $ tri s
PC c [] -> P.PCon $ tri c
PC c a -> P.PC (tri c) (map trp a)
PP p c [] -> P.PQ (tri p) (tri c)
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r]
PString s -> P.PStr s
PInt i -> P.PInt i
PFloat i -> P.PFloat i
PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
PAs x p -> P.PAs (tri x) (trp p)
PAlt p q -> P.PDisj (trp p) (trp q)
PSeq p q -> P.PSeq (trp p) (trp q)
PRep p -> P.PRep (trp p)
PNeg p -> P.PNeg (trp p)
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
where
t' = trt t
x = [trLabelIdent lab]
trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
trCase (patt, trm) = P.Case (trp patt) (trt trm)
trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
tri :: Ident -> P.PIdent
tri i = ppIdent (prIdent i)
ppIdent i = P.PIdent ((0,0),i)
trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i)
trLabel :: Label -> P.Label
trLabel i = case i of
LIdent s -> P.LPIdent $ ppIdent s
LVar i -> P.LVar $ toInteger i
trLabelIdent i = ppIdent $ case i of
LIdent s -> s
LVar i -> "v" ++ show i --- should not happen
mkName :: Ident -> P.Name
mkName = P.PIdentName . tri

172
src-3.0/GF/Devel/Grammar/Grammar.hs
View File

@@ -1,172 +0,0 @@
module GF.Devel.Grammar.Grammar where
import GF.Infra.Ident
import GF.Data.Operations
import Data.Map
------------------
-- definitions --
------------------
data GF = GF {
gfabsname :: Maybe Ident ,
gfcncnames :: [Ident] ,
gflags :: Map Ident String , -- value of a global flag
gfmodules :: Map Ident Module
}
data Module = Module {
mtype :: ModuleType,
miscomplete :: Bool,
minterfaces :: [(Ident,Ident)], -- non-empty for functors
minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for inst'ions
mextends :: [(Ident,MInclude)],
mopens :: [(Ident,Ident)], -- used name, original name
mflags :: Map Ident String,
mjments :: Map Ident Judgement
}
data ModuleType =
MTAbstract
| MTConcrete Ident
| MTInterface
| MTInstance Ident
| MTGrammar
deriving Eq
data MInclude =
MIAll
| MIExcept [Ident]
| MIOnly [Ident]
type Indirection = (Ident,Bool) -- module of origin, whether canonical
data Judgement = Judgement {
jform :: JudgementForm, -- cat fun lincat lin oper param
jtype :: Type, -- context type lincat - type PType
jdef :: Term, -- lindef def lindef lin def constrs
jprintname :: Term, -- - - prname prname - -
jlink :: Ident, -- if inherited, the supermodule name, else #
jposition :: Int -- line number where def begins
}
deriving Show
data JudgementForm =
JCat
| JFun
| JLincat
| JLin
| JOper
| JParam
| JLink
deriving (Eq,Show)
type Type = Term
data Term =
Vr Ident -- ^ variable
| Con Ident -- ^ constructor
| EData -- ^ to mark in definition that a fun is a constructor
| Sort String -- ^ predefined type
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@
| Empty -- ^ the empty string @[]@
| App Term Term -- ^ application: @f a@
| Abs Ident Term -- ^ abstraction: @\x -> b@
| Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0)
| Prod Ident Term Term -- ^ function type: @(x : A) -> B@
| Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@
-- only used in internal representation
| Typed Term Term -- ^ type-annotated term
--
-- /below this, the constructors are only for concrete syntax/
| Example Term String -- ^ example-based term: @in M.C "foo"
| RecType [Labelling] -- ^ record type: @{ p : A ; ...}@
| R [Assign] -- ^ record: @{ p = a ; ...}@
| P Term Label -- ^ projection: @r.p@
| PI Term Label Int -- ^ index-annotated projection
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
| Table Term Term -- ^ table type: @P => A@
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@
| V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@
| S Term Term -- ^ selection: @t ! p@
| Val Type Int -- ^ parameter value number: @T # i#
| Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
| Q Ident Ident -- ^ qualified constant from a module
| QC Ident Ident -- ^ qualified constructor from a module
| C Term Term -- ^ concatenation: @s ++ t@
| Glue Term Term -- ^ agglutination: @s + t@
| EPatt Patt
| EPattType Term
| EParam Term [(Ident,Context)] -- to encode parameter constructor sets
| FV [Term] -- ^ free variation: @variants { s ; ... }@
| Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@
| Overload [(Type,Term)]
deriving (Read, Show, Eq, Ord)
data Patt =
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@
| PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@
| PV Ident -- ^ variable pattern: @x@
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@
| PString String -- ^ string literal pattern: @\"foo\"@
| PInt Integer -- ^ integer literal pattern: @12@
| PFloat Double -- ^ float literal pattern: @1.2@
| PT Type Patt -- ^ type-annotated pattern
| PAs Ident Patt -- ^ as-pattern: x@p
-- regular expression patterns
| PNeg Patt -- ^ negated pattern: -p
| PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2
| PSeq Patt Patt -- ^ sequence of token parts: p + q
| PRep Patt -- ^ repetition of token part: p*
| PChar -- ^ string of length one: ?
| PChars String -- ^ list of characters: ["aeiou"]
| PMacro Ident -- #p
| PM Ident Ident -- #m.p
deriving (Read, Show, Eq, Ord)
-- | to guide computation and type checking of tables
data TInfo =
TRaw -- ^ received from parser; can be anything
| TTyped Type -- ^ type annotated, but can be anything
| TComp Type -- ^ expanded
| TWild Type -- ^ just one wild card pattern, no need to expand
deriving (Read, Show, Eq, Ord)
-- | record label
data Label =
LIdent String
| LVar Int
deriving (Read, Show, Eq, Ord)
type MetaSymb = Int
type Decl = (Ident,Term) -- (x:A) (_:A) A
type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A)
type Substitution = [(Ident, Term)]
type Equation = ([Patt],Term)
type Labelling = (Label, Term)
type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term)
type LocalDef = (Ident, (Maybe Type, Term))

168
src-3.0/GF/Devel/Grammar/Lookup.hs
View File

@@ -1,168 +0,0 @@
module GF.Devel.Grammar.Lookup 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.Data.Operations
import Control.Monad (liftM)
import Data.Map
import Data.List (sortBy) ----
-- look up fields for a constant in a grammar
lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a
lookupJField field gf m c = do
j <- lookupJudgement gf m c
return $ field j
lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm
lookupJForm = lookupJField jform
-- the following don't (need to) check that the jment form is adequate
lookupCatContext :: GF -> Ident -> Ident -> Err Context
lookupCatContext gf m c = do
ty <- lookupJField jtype gf m c
return $ contextOfType ty
lookupFunType :: GF -> Ident -> Ident -> Err Term
lookupFunType = lookupJField jtype
lookupLin :: GF -> Ident -> Ident -> Err Term
lookupLin = lookupJField jdef
lookupLincat :: GF -> Ident -> Ident -> Err Term
lookupLincat = lookupJField jtype
lookupOperType :: GF -> Ident -> Ident -> Err Term
lookupOperType gr m c = do
ju <- lookupJudgement gr m c
case jform ju of
JParam -> return typePType
_ -> case jtype ju of
Meta _ -> fail ("no type given to " ++ prIdent m ++ "." ++ prIdent c)
ty -> return ty
---- can't be just lookupJField jtype
lookupOperDef :: GF -> Ident -> Ident -> Err Term
lookupOperDef = lookupJField jdef
lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))]
lookupOverload gr m c = do
tr <- lookupJField jdef gr m c
case tr of
Overload tysts -> return
[(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty]
_ -> Bad $ prt c +++ "is not an overloaded operation"
lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)]
lookupParams gf m c = do
EParam _ ty <- lookupJField jdef gf m c
return ty
lookupParamConstructor :: GF -> Ident -> Ident -> Err Type
lookupParamConstructor = lookupJField jtype
lookupParamValues :: GF -> Ident -> Ident -> Err [Term]
lookupParamValues gf m c = do
ps <- lookupParams gf m c
liftM concat $ mapM mkPar ps
where
mkPar (f,co) = do
vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co
return $ lmap (mkApp (QC m f)) vs
lookupFlags :: GF -> Ident -> [(Ident,String)]
lookupFlags gf m = errVal [] $ do
mo <- lookupModule gf m
return $ toList $ mflags mo
allParamValues :: GF -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
App (Q (IC "Predef") (IC "Ints")) (EInt n) ->
return [EInt i | i <- [0..n]]
QC p c -> lookupParamValues cnc p c
Q p c -> lookupParamValues cnc p c ----
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
tss <- mapM allPV tys
return [R (zipAssign ls ts) | ts <- combinations tss]
_ -> prtBad "cannot find parameter values for" ptyp
where
allPV = allParamValues cnc
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
abstractOfConcrete :: GF -> Ident -> Err Ident
abstractOfConcrete gf m = do
mo <- lookupModule gf m
case mtype mo of
MTConcrete a -> return a
MTInstance a -> return a
MTGrammar -> return m
_ -> prtBad "not concrete module" m
allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)]
allOrigJudgements gf m = errVal [] $ do
mo <- lookupModule gf m
return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink]
allConcretes :: GF -> Ident -> [Ident]
allConcretes gf m =
[c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m]
-- | select just those modules that a given one depends on, including itself
partOfGrammar :: GF -> (Ident,Module) -> GF
partOfGrammar gr (i,mo) = gr {
gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor]
}
where
mos = toList $ gfmodules gr
modsFor = i : allDepsModule gr mo
allDepsModule :: GF -> Module -> [Ident]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n]
mods = toList $ gfmodules gr
-- | initial dependency list
depPathModule :: Module -> [Ident]
depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where
fors = case mtype mo of
MTConcrete i -> [i]
MTInstance i -> [i]
_ -> []
-- infrastructure for lookup
lookupModule :: GF -> Ident -> Err Module
lookupModule gf m = do
maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf)
-- this finds the immediate definition, which can be a link
lookupIdent :: GF -> Ident -> Ident -> Err Judgement
lookupIdent gf m c = do
mo <- lookupModule gf m
maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo)
-- this follows the link
lookupJudgement :: GF -> Ident -> Ident -> Err Judgement
lookupJudgement gf m c = do
ju <- lookupIdent gf m c
case jform ju of
JLink -> lookupJudgement gf (jlink ju) c
_ -> return ju
mlookup = Data.Map.lookup
raiseIdent msg i = raise (msg +++ prIdent i)
lmap = Prelude.map
llookup = Prelude.lookup

434
src-3.0/GF/Devel/Grammar/Macros.hs
View File

@@ -1,434 +0,0 @@
module GF.Devel.Grammar.Macros where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Infra.Ident
import GF.Data.Str
import GF.Data.Operations
import qualified Data.Map as Map
import Control.Monad (liftM,liftM2)
-- analyse types and terms
contextOfType :: Type -> Context
contextOfType ty = co where (co,_,_) = typeForm ty
typeForm :: Type -> (Context,Term,[Term])
typeForm t = (co,f,a) where
(co,t2) = prodForm t
(f,a) = appForm t2
termForm :: Term -> ([Ident],Term,[Term])
termForm t = (co,f,a) where
(co,t2) = absForm t
(f,a) = appForm t2
prodForm :: Type -> (Context,Term)
prodForm t = case t of
Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val
_ -> ([],t)
absForm :: Term -> ([Ident],Term)
absForm t = case t of
Abs x val -> (x:co,t2) where (co,t2) = absForm val
_ -> ([],t)
appForm :: Term -> (Term,[Term])
appForm tr = (f,reverse xs) where
(f,xs) = apps tr
apps t = case t of
App f a -> (f2,a:a2) where (f2,a2) = appForm f
_ -> (t,[])
valCat :: Type -> Err (Ident,Ident)
valCat typ = case typeForm typ of
(_,Q m c,_) -> return (m,c)
typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
typeRawSkeleton typ = do
let (cont,typ) = prodForm typ
args <- mapM (typeRawSkeleton . snd) cont
return ([(length c, v) | (c,v) <- args], typ)
type MCat = (Ident,Ident)
sortMCat :: String -> MCat
sortMCat s = (identC "_", identC s)
--- hack for Editing.actCat in empty state
errorCat :: MCat
errorCat = (identC "?", identC "?")
getMCat :: Term -> Err MCat
getMCat t = case t of
Q m c -> return (m,c)
QC m c -> return (m,c)
Sort s -> return $ sortMCat s
App f _ -> getMCat f
_ -> error $ "no qualified constant" +++ show t
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do
(cont,val) <- typeRawSkeleton typ
cont' <- mapPairsM getMCat cont
val' <- getMCat val
return (cont',val')
-- construct types and terms
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(identW, ty) | ty <- tt]) t -- nondep prod
mkApp :: Term -> [Term] -> Term
mkApp = foldl App
mkAbs :: [Ident] -> Term -> Term
mkAbs xs t = foldr Abs t xs
mkCTable :: [Ident] -> Term -> Term
mkCTable ids v = foldr ccase v ids where
ccase x t = T TRaw [(PV x,t)]
appCons :: Ident -> [Term] -> Term
appCons = mkApp . Con
appc :: String -> [Term] -> Term
appc = appCons . identC
tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
tuple2recordType :: [Term] -> [Labelling]
tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
tuple2recordPatt :: [Patt] -> [(Label,Patt)]
tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
tupleLabel :: Int -> Label
tupleLabel i = LIdent $ "p" ++ show i
assign :: Label -> Term -> Assign
assign l t = (l,(Nothing,t))
assignT :: Label -> Type -> Term -> Assign
assignT l a t = (l,(Just a,t))
unzipR :: [Assign] -> ([Label],[Term])
unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
mkDecl :: Term -> Decl
mkDecl typ = (identW, typ)
mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs
mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
mkRecType :: (Int -> Label) -> [Type] -> Type
mkRecType = mkRecTypeN 0
plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> Bad $ "clashing labels" +++ unwords (map show ls)
_ -> Bad ("cannot add record types" +++ show t1 +++ "and" +++ show t2)
plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
case (t1,t2) of
(R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> Bad ("cannot add records" +++ show t1 +++ "and" +++ show t2)
zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
defLinType :: Type
defLinType = RecType [(LIdent "s", typeStr)]
meta0 :: Term
meta0 = Meta 0
ident2label :: Ident -> Label
ident2label c = LIdent (prIdent c)
label2ident :: Label -> Ident
label2ident (LIdent c) = identC c
----label2ident :: Label -> Ident
----label2ident = identC . prLabel
-- to apply a term operation to every term in a judgement, module, grammar
termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF
termOpGF f = moduleOpGF (termOpModule f)
moduleOpGF :: Monad m => (Module -> m Module) -> GF -> m GF
moduleOpGF f g = do
ms <- mapMapM f (gfmodules g)
return g {gfmodules = ms}
termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module
termOpModule f = judgementOpModule fj where
fj = termOpJudgement f
judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module
judgementOpModule f m = do
mjs <- mapMapM f (mjments m)
return m {mjments = mjs}
entryOpModule :: Monad m =>
(Ident -> Judgement -> m Judgement) -> Module -> m Module
entryOpModule f m = do
mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m
return $ m {mjments = mjs}
where
mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j))
termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
termOpJudgement f j = do
jtyp <- f (jtype j)
jde <- f (jdef j)
jpri <- f (jprintname j)
return $ j {
jtype = jtyp,
jdef = jde,
jprintname = jpri
}
-- | to define compositional term functions
composSafeOp :: (Term -> Term) -> Term -> Term
composSafeOp op trm = case composOp (mkMonadic op) trm of
Ok t -> t
_ -> error "the operation is safe isn't it ?"
where
mkMonadic f = return . f
-- | to define compositional monadic term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm = case trm of
App c a ->
do c' <- co c
a' <- co a
return (App c' a')
Abs x b ->
do b' <- co b
return (Abs x b')
Prod x a b ->
do a' <- co a
b' <- co b
return (Prod x a' b')
S c a ->
do c' <- co c
a' <- co a
return (S c' a')
Table a c ->
do a' <- co a
c' <- co c
return (Table a' c')
R r ->
do r' <- mapAssignM co r
return (R r')
RecType r ->
do r' <- mapPairListM (co . snd) r
return (RecType r')
P t i ->
do t' <- co t
return (P t' i)
PI t i j ->
do t' <- co t
return (PI t' i j)
ExtR a c ->
do a' <- co a
c' <- co c
return (ExtR a' c')
T i cc ->
do cc' <- mapPairListM (co . snd) cc
i' <- changeTableType co i
return (T i' cc')
Eqs cc ->
do cc' <- mapPairListM (co . snd) cc
return (Eqs cc')
EParam ty cos ->
do ty' <- co ty
cos' <- mapPairListM (mapPairListM (co . snd) . snd) cos
return (EParam ty' cos')
V ty vs ->
do ty' <- co ty
vs' <- mapM co vs
return (V ty' vs')
Let (x,(mt,a)) b ->
do a' <- co a
mt' <- case mt of
Just t -> co t >>= (return . Just)
_ -> return mt
b' <- co b
return (Let (x,(mt',a')) b')
C s1 s2 ->
do v1 <- co s1
v2 <- co s2
return (C v1 v2)
Glue s1 s2 ->
do v1 <- co s1
v2 <- co s2
return (Glue v1 v2)
Alts (t,aa) ->
do t' <- co t
aa' <- mapM (pairM co) aa
return (Alts (t',aa'))
FV ts -> mapM co ts >>= return . FV
Overload tts -> do
tts' <- mapM (pairM co) tts
return $ Overload tts'
EPattType ty ->
do ty' <- co ty
return (EPattType ty')
_ -> return trm -- covers K, Vr, Cn, Sort
---- should redefine using composOp
collectOp :: (Term -> [a]) -> Term -> [a]
collectOp co trm = case trm of
App c a -> co c ++ co a
Abs _ b -> co b
Prod _ a b -> co a ++ co b
S c a -> co c ++ co a
Table a c -> co a ++ co c
ExtR a c -> co a ++ co c
R r -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r
RecType r -> concatMap (co . snd) r
P t i -> co t
T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
V _ cc -> concatMap co cc --- nor from type annot
Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
C s1 s2 -> co s1 ++ co s2
Glue s1 s2 -> co s1 ++ co s2
Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
FV ts -> concatMap co ts
_ -> [] -- covers K, Vr, Cn, Sort, Ready
--- just aux to composOp?
mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
changeTableType co i = case i of
TTyped ty -> co ty >>= return . TTyped
TComp ty -> co ty >>= return . TComp
TWild ty -> co ty >>= return . TWild
_ -> return i
patt2term :: Patt -> Term
patt2term pt = case pt of
PV x -> Vr x
PW -> Vr identW --- not parsable, should not occur
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
PFloat i -> EFloat i
PString s -> K s
PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding
PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
PRep a -> appc "*" [(patt2term a)] --- an encoding
PNeg a -> appc "-" [(patt2term a)] --- an encoding
term2patt :: Term -> Err Patt
term2patt trm = case Ok (termForm trm) of
Ok ([], Vr x, []) -> return (PV x)
Ok ([], QC p c, aa) -> do
aa' <- mapM term2patt aa
return (PP p c aa')
Ok ([], R r, []) -> do
let (ll,aa) = unzipR r
aa' <- mapM term2patt aa
return (PR (zip ll aa'))
Ok ([],EInt i,[]) -> return $ PInt i
Ok ([],EFloat i,[]) -> return $ PFloat i
Ok ([],K s, []) -> return $ PString s
--- encodings due to excessive use of term-patt convs. AR 7/1/2005
Ok ([], Con (IC "@"), [Vr a,b]) -> do
b' <- term2patt b
return (PAs a b')
Ok ([], Con (IC "-"), [a]) -> do
a' <- term2patt a
return (PNeg a')
Ok ([], Con (IC "*"), [a]) -> do
a' <- term2patt a
return (PRep a')
Ok ([], Con (IC "+"), [a,b]) -> do
a' <- term2patt a
b' <- term2patt b
return (PSeq a' b')
Ok ([], Con (IC "|"), [a,b]) -> do
a' <- term2patt a
b' <- term2patt b
return (PAlt a' b')
Ok ([], Con c, aa) -> do
aa' <- mapM term2patt aa
return (PC c aa')
_ -> Bad $ "no pattern corresponds to term" +++ show trm
getTableType :: TInfo -> Err Type
getTableType i = case i of
TTyped ty -> return ty
TComp ty -> return ty
TWild ty -> return ty
_ -> Bad "the table is untyped"
-- | to get a string from a term that represents a sequence of terminals
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case t of
K s -> return [str s]
Empty -> return [str []]
C s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [plusStr x y | x <- s', y <- t']
Glue s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [glueStr x y | x <- s', y <- t']
Alts (d,vs) -> do
d0 <- strsFromTerm d
v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs
let vs' = zip v0 c0
return [strTok (str2strings def) vars |
def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- combinations v0]
]
FV ts -> mapM strsFromTerm ts >>= return . concat
_ -> Bad $ "cannot get Str from term" +++ show t
---- given in lib?
mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v)
mapMapM f =
liftM Map.fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . Map.assocs

146
src-3.0/GF/Devel/Grammar/PatternMatch.hs
View File

@@ -1,146 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PatternMatch
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/12 12:38:29 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
-----------------------------------------------------------------------------
module GF.Devel.Grammar.PatternMatch (matchPattern,
testOvershadow,
findMatch
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident
import GF.Data.Operations
import Data.List
import Control.Monad
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
matchPattern pts term =
if not (isInConstantForm term)
then prtBad "variables occur in" term
else
errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
findMatch [([p],t) | (p,t) <- pts] [term]
testOvershadow :: [Patt] -> [Term] -> Err [Patt]
testOvershadow pts vs = do
let numpts = zip pts [0..]
let cases = [(p,EInt i) | (p,i) <- numpts]
ts <- mapM (liftM fst . matchPattern cases) vs
return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
(patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
tryMatch (p,t) = do
let t' = termForm t
trym p t'
where
isInConstantFormt = True -- tested already
trym p t' =
case (p,t') of
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
(PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
(PV x, _) | isInConstantFormt -> return [(x,t)]
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PC p pp, ([], Con f, tt)) |
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP q p pp, ([], QC r f, tt)) |
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
---- hack for AppPredef bug
(PP q p pp, ([], Q r f, tt)) |
-- q `eqStrIdent` r && ---
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PR r, ([],R r',[])) |
all (`elem` map fst r') (map fst r) ->
do matches <- mapM tryMatch
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
return (concat matches)
(PT _ p',_) -> trym p' t'
-- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
(PAs x p',_) -> do
subst <- trym p' t'
return $ (x,t) : subst
(PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
(PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return []
_ -> prtBad "no match with negative pattern" p
(PSeq p1 p2, ([],K s, [])) -> do
let cuts = [splitAt n s | n <- [0 .. length s]]
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
return (concat matches)
(PRep p1, ([],K s, [])) -> checks [
trym (foldr (const (PSeq p1)) (PString "")
[1..n]) t' | n <- [0 .. length s]
] >>
return []
(PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> prtBad "no match in case expr for" t
eqStrIdent = (==) ----
isInConstantForm :: Term -> Bool
isInConstantForm trm = case trm of
Con _ -> True
Q _ _ -> True
QC _ _ -> True
Abs _ _ -> True
App c a -> isInConstantForm c && isInConstantForm a
R r -> all (isInConstantForm . snd . snd) r
K _ -> True
Empty -> True
EInt _ -> True
_ -> False ---- isInArgVarForm trm
varsOfPatt :: Patt -> [Ident]
varsOfPatt p = case p of
PV x -> [x | not (isWildIdent x)]
PC _ ps -> concat $ map varsOfPatt ps
PP _ _ ps -> concat $ map varsOfPatt ps
PR r -> concat $ map (varsOfPatt . snd) r
PT _ q -> varsOfPatt q
_ -> []

246
src-3.0/GF/Devel/Grammar/PrGF.hs
View File

@@ -1,246 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PrGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/04 11:45:38 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003 - 4/12/2007
--
-- printing and prettyprinting class for source grammar
--
-- 8\/1\/2004:
-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
-- only the former is ever needed.
-----------------------------------------------------------------------------
module GF.Devel.Grammar.PrGF where
import qualified GF.Devel.Compile.PrintGF as P
import GF.Devel.Grammar.GFtoSource
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
----import GF.Grammar.Values
----import GF.Infra.Option
import GF.Infra.Ident
import GF.Infra.CompactPrint
----import GF.Data.Str
import GF.Data.Operations
----import GF.Data.Zipper
import Data.List (intersperse)
class Print a where
prt :: a -> String
-- | printing with parentheses, if needed
prt2 :: a -> String
-- | pretty printing
prpr :: a -> [String]
-- | printing without ident qualifications
prt_ :: a -> String
prt2 = prt
prt_ = prt
prpr = return . prt
-- 8/1/2004
--- Usually followed principle: prt_ for displaying in the editor, prt
--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
--- only the former is ever needed.
cprintTree :: P.Print a => a -> String
cprintTree = compactPrint . P.printTree
-- | to show terms etc in error messages
prtBad :: Print a => String -> a -> Err b
prtBad s a = Bad (s +++ prt a)
prGF :: GF -> String
prGF = cprintTree . trGrammar
instance Print GF where
prt = cprintTree . trGrammar
prModule :: SourceModule -> String
prModule = cprintTree . trModule
instance Print Judgement where
prt j = cprintTree $ trAnyDef (identW, j)
---- prt_ = prExp
instance Print Term where
prt = cprintTree . trt
---- prt_ = prExp
instance Print Ident where
prt = cprintTree . tri
instance Print Patt where
prt = P.printTree . trp
instance Print Label where
prt = P.printTree . trLabel
{-
instance Print MetaSymb where
prt (MetaSymb i) = "?" ++ show i
prParam :: Param -> String
prParam (c,co) = prt c +++ prContext co
prContext :: Context -> String
prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
-- printing values and trees in editing
instance Print a => Print (Tr a) where
prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
-- | we cannot define the method prt_ in this way
prt_Tree :: Tree -> String
prt_Tree = prt_ . tree2exp
instance Print TrNode where
prt (N (bi,at,vt,(cs,ms),_)) =
prBinds bi ++
prt at +++ ":" +++ prt vt
+++ prConstraints cs +++ prMetaSubst ms
prt_ (N (bi,at,vt,(cs,ms),_)) =
prBinds bi ++
prt_ at +++ ":" +++ prt_ vt
+++ prConstraints cs +++ prMetaSubst ms
prMarkedTree :: Tr (TrNode,Bool) -> [String]
prMarkedTree = prf 1 where
prf ind t@(Tr (node, trees)) =
prNode ind node : concatMap (prf (ind + 2)) trees
prNode ind node = case node of
(n, False) -> indent ind (prt_ n)
(n, _) -> '*' : indent (ind - 1) (prt_ n)
prTree :: Tree -> [String]
prTree = prMarkedTree . mapTr (\n -> (n,False))
-- | a pretty-printer for parsable output
tree2string :: Tree -> String
tree2string = unlines . prprTree
prprTree :: Tree -> [String]
prprTree = prf False where
prf par t@(Tr (node, trees)) =
parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
prb [] = ""
prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
parIf par (s:ss) = map (indent 2) $
if par
then ('(':s) : ss ++ [")"]
else s:ss
ifPar (Tr (N ([],_,_,_,_), [])) = False
ifPar _ = True
-- auxiliaries
prConstraints :: Constraints -> String
prConstraints = concat . prConstrs
prMetaSubst :: MetaSubst -> String
prMetaSubst = concat . prMSubst
prEnv :: Env -> String
---- prEnv [] = prCurly "" ---- for debugging
prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
prConstrs :: Constraints -> [String]
prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
prMSubst :: MetaSubst -> [String]
prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
prBinds bi = if null bi
then []
else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
where
prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
instance Print Val where
prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
prt (VApp u v) = prt u +++ prv1 v
prt (VCn mc) = prQIdent_ mc
prt (VClos env e) = case e of
Meta _ -> prt_ e ++ prEnv env
_ -> prt_ e ---- ++ prEnv env ---- for debugging
prt VType = "Type"
prv1 v = case v of
VApp _ _ -> prParenth $ prt v
VClos _ _ -> prParenth $ prt v
_ -> prt v
instance Print Atom where
prt (AtC f) = prQIdent f
prt (AtM i) = prt i
prt (AtV i) = prt i
prt (AtL s) = prQuotedString s
prt (AtI i) = show i
prt (AtF i) = show i
prt_ (AtC (_,f)) = prt f
prt_ a = prt a
prQIdent :: QIdent -> String
prQIdent (m,f) = prt m ++ "." ++ prt f
prQIdent_ :: QIdent -> String
prQIdent_ (_,f) = prt f
-- | print terms without qualifications
prExp :: Term -> String
prExp e = case e of
App f a -> pr1 f +++ pr2 a
Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b
Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
Q _ c -> prt c
QC _ c -> prt c
_ -> prt e
where
pr1 e = case e of
Abs _ _ -> prParenth $ prExp e
Prod _ _ _ -> prParenth $ prExp e
_ -> prExp e
pr2 e = case e of
App _ _ -> prParenth $ prExp e
_ -> pr1 e
-- | option @-strip@ strips qualifications
prTermOpt :: Options -> Term -> String
prTermOpt opts = if oElem nostripQualif opts then prt else prExp
-- | to get rid of brackets in the editor
prRefinement :: Term -> String
prRefinement t = case t of
Q m c -> prQIdent (m,c)
QC m c -> prQIdent (m,c)
_ -> prt t
prOperSignature :: (QIdent,Type) -> String
prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
-- to look up a constant etc in a search tree
lookupIdent :: Ident -> BinTree Ident b -> Err b
lookupIdent c t = case lookupTree prt c t of
Ok v -> return v
_ -> prtBad "unknown identifier" c
lookupIdentInfo :: Module Ident f a -> Ident -> Err a
lookupIdentInfo mo i = lookupIdent i (jments mo)
-}

348
src-3.0/GF/Devel/Infra/ReadFiles.hs
View File

@@ -1,348 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : ReadFiles
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.26 $
--
-- Decide what files to read as function of dependencies and time stamps.
--
-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
--
-- to find all files that have to be read, put them in dependency order, and
-- decide which files need recompilation. Name @file.gf@ is returned for them,
-- and @file.gfo@ otherwise.
-----------------------------------------------------------------------------
module GF.Devel.Infra.ReadFiles (-- * Heading 1
getAllFiles,fixNewlines,ModName,getOptionsFromFile,
-- * Heading 2
gfoFile,gfFile,isGFO,resModName,isOldFile
) where
import GF.Devel.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
import GF.Infra.Option
import GF.Data.Operations
import GF.Devel.UseIO
import System
import Data.Char
import Control.Monad
import Data.List
import System.Directory
type ModName = String
type ModEnv = [(ModName,ModTime)]
getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
getAllFiles opts ps env file = do
-- read module headers from all files recursively
ds0 <- getImports ps file
let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0]
if oElem beVerbose opts
then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds)
else return ()
-- get a topological sorting of files: returns file names --- deletes paths
ds1 <- ioeErr $ either
return
(\ms -> Bad $ "circular modules" +++
unwords (map show (head ms))) $ topoTest $ map fst ds
-- associate each file name with its path --- more optimal: save paths in ds1
let paths = [(f,p) | ((f,_),p) <- ds]
let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]]
if oElem fromSource opts
then return [gfFile (p </> f) | (p,f) <- pds1]
else do
ds2 <- ioeIO $ mapM (selectFormat opts env) pds1
let ds4 = needCompile opts (map fst ds0) ds2
return ds4
-- to decide whether to read gf or gfo, or if in env; returns full file path
data CompStatus =
CSComp -- compile: read gf
| CSRead -- read gfo
| CSEnv -- gfo is in env
| CSEnvR -- also gfr is in env
| CSDont -- don't read at all
| CSRes -- read gfr
deriving (Eq,Show)
-- for gfo, we also return ModTime to cope with earlier compilation of libs
selectFormat :: Options -> ModEnv -> (InitPath,ModName) ->
IO (ModName,(InitPath,(CompStatus,Maybe ModTime)))
selectFormat opts env (p,f) = do
let pf = p </> f
let mtenv = lookup f env -- Nothing if f is not in env
let rtenv = lookup (resModName f) env
let fromComp = oElem isCompiled opts -- i -gfo
mtgfc <- getModTime $ gfoFile pf
mtgf <- getModTime $ gfFile pf
let stat = case (rtenv,mtenv,mtgfc,mtgf) of
(_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv)
(_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc)
(Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv)
(_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv)
(_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> (CSRead,Just tgfc)
(_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
(_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist
_ -> (CSComp,Nothing)
return $ (f, (p,stat))
needCompile :: Options ->
[ModuleHeader] ->
[(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath]
needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where
deps = [(snd m,map fst ms) | (m,ms) <- headers]
typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers]
uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m]
stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0
allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where
add os = [m | o <- os, Just n <- [lookup o deps],m <- n]
-- only treat reused, interface, or instantiation if needed
sfiles = sfiles0 ---- map relevant sfiles0
relevant fp@(f,(p,(st,_))) =
let us = uses f
isUsed = not (null us)
in
if not (isUsed && all noComp us) then
fp else
if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource]
||
(isUsed && all isAux us)) then
(f,(p,(CSDont,Nothing))) else
fp
isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd
noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst
-- mark as to be compiled those whose gfo is earlier than a deeper gfo
sfiles1 = map compTimes sfiles
compTimes fp@(f,(p,(_, Just t))) =
if any (> t) [t' | Just fs <- [lookup f deps],
f0 <- fs,
Just (_,(_,Just t')) <- [lookup f0 sfiles]]
then (f,(p,(CSComp, Nothing)))
else fp
compTimes fp = fp
-- start with the changed files themselves; returns [ModName]
changed = [f | (f,(_,(CSComp,_))) <- sfiles1]
-- add other files that depend on some changed file; returns [ModName]
iter np = let new = [f | (f,fs) <- deps,
not (elem f np), any (flip elem np) fs]
in if null new then np else (iter (new ++ np))
-- for each module in the full list, compile if depends on what needs compile
-- returns [FullPath]
mark cs = [(f,(path,st)) |
(f,(path,(st0,_))) <- sfiles1,
let st = if (elem f cs) then CSComp else st0]
-- Also read res if the option "retain" is present
-- Also, if a "with" file has to be compiled, read its mother file from source
res cs = map mkRes cs where
mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of
t | (not (null [m | (m,(_,CSComp)) <- cs,
Just ms <- [lookup m allDeps], elem f ms])
|| oElem retainOpers opts)
-> if elem t [MTyResource,MTyIncResource]
then (f,(path,CSRes)) else
if t == MTyIncomplete
then (f,(path,CSComp)) else
x
_ -> x
mkRes x = x
-- construct list of paths to read
paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]]
mkName f p st = mk (p </> f) where
mk = case st of
CSComp -> gfFile
CSRead -> gfoFile
CSRes -> gfoFile ---- gfr
isGFO :: FilePath -> Bool
isGFO = (== ".gfn") . takeExtensions
gfoFile :: FilePath -> FilePath
gfoFile f = addExtension f "gfn"
gfFile :: FilePath -> FilePath
gfFile f = addExtension f "gf"
resModName :: ModName -> ModName
resModName = ('#':)
-- to get imports without parsing the whole files
getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)]
getImports ps = get [] where
get ds file0 = do
let name = dropExtension file0 ---- dropExtension file0
(p,s) <- tryRead name
let ((typ,mname),imps) = importsOfFile s
let namebody = takeFileName name
ioeErr $ testErr (mname == namebody) $
"module name" +++ mname +++ "differs from file name" +++ namebody
case imps of
_ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read
[] -> return $ (((typ,name),[]),p):ds
_ -> do
let files = map (gfFile . fst) imps
foldM get ((((typ,name),imps),p):ds) files
tryRead name = do
file <- do
let file_gf = gfFile name
b <- doesFileExistPath ps file_gf -- try gf file first
if b then return file_gf else do
return (gfoFile name) -- gfo next
readFileIfPath ps $ file
-- internal module dep information
data ModUse =
MUReuse
| MUInstance
| MUComplete
| MUOther
deriving (Eq,Show)
data ModTyp =
MTyResource
| MTyIncomplete
| MTyIncResource -- interface, incomplete resource
| MTyOther
deriving (Eq,Show)
type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)])
importsOfFile :: String -> ModuleHeader
importsOfFile =
getModuleHeader . -- analyse into mod header
filter (not . spec) . -- ignore keywords and special symbols
unqual . -- take away qualifiers
unrestr . -- take away union restrictions
takeWhile (not . term) . -- read until curly or semic
lexs . -- analyse into lexical tokens
unComm -- ignore comments before the headed line
where
term = flip elem ["{",";"]
spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"]
unqual ws = case ws of
"(":q:ws' -> unqual ws'
w:ws' -> w:unqual ws'
_ -> ws
unrestr ws = case ws of
"[":ws' -> unrestr $ tail $ dropWhile (/="]") ws'
w:ws' -> w:unrestr ws'
_ -> ws
getModuleHeader :: [String] -> ModuleHeader -- with, reuse
getModuleHeader ws = case ws of
"incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in
case ty of
MTyResource -> ((MTyIncResource,name),us)
_ -> ((MTyIncomplete,name),us)
"interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in
((MTyIncResource,name),us)
"resource":name:ws2 -> case ws2 of
"reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)])
m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms])
ms -> ((MTyResource,name),[(n,MUOther) | n <- ms])
"instance":name:m:ws2 -> case ws2 of
"reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)])
n:"with":ms ->
((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms])
ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms])
"concrete":name:a:ws2 -> case span (/= "with") ws2 of
(es,_:ms) -> ((MTyOther,name),
[(m,MUOther) | m <- es] ++
[(n,MUComplete) | n <- ms])
--- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms])
(ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms])
_:name:ws2 -> case ws2 of
"reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)])
---- m:n:"with":ms ->
---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms])
m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms])
ms -> ((MTyOther,name),[(n,MUOther) | n <- ms])
_ -> error "the file is empty"
unComm s = case s of
'-':'-':cs -> unComm $ dropWhile (/='\n') cs
'{':'-':cs -> dpComm cs
c:cs -> c : unComm cs
_ -> s
dpComm s = case s of
'-':'}':cs -> unComm cs
c:cs -> dpComm cs
_ -> s
lexs s = x:xs where
(x,y) = head $ lex s
xs = if null y then [] else lexs y
-- | options can be passed to the compiler by comments in @--#@, in the main file
getOptionsFromFile :: FilePath -> IO Options
getOptionsFromFile file = do
s <- readFileIfStrict file
let ls = filter (isPrefixOf "--#") $ lines s
return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls
-- | check if old GF file
isOldFile :: FilePath -> IO Bool
isOldFile f = do
s <- readFileIfStrict f
let s' = unComm s
return $ not (null s') && old (head (words s'))
where
old = flip elem $ words
"cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule"
-- | old GF tolerated newlines in quotes. No more supported!
fixNewlines :: String -> String
fixNewlines s = case s of
'"':cs -> '"':mk cs
c :cs -> c:fixNewlines cs
_ -> s
where
mk s = case s of
'\\':'"':cs -> '\\':'"': mk cs
'"' :cs -> '"' :fixNewlines cs
'\n' :cs -> '\\':'n': mk cs
c :cs -> c : mk cs
_ -> s

269
src-3.0/GF/Devel/Options.hs
View File

@@ -1,269 +0,0 @@
module GF.Devel.Options
(
Err(..), -- FIXME: take from somewhere else
Options(..),
Mode(..), Phase(..), OutputFormat(..), Optimization(..),
parseOptions, helpMessage
) where
import Control.Monad
import Data.Char (toLower)
import Data.List
import Data.Maybe
import System.Console.GetOpt
import System.FilePath
usageHeader :: String
usageHeader = unlines
["Usage: gfc [OPTIONS] [FILE [...]]",
"",
"How each FILE is handled depends on the file name suffix:",
"",
".gf Normal or old GF source, will be compiled.",
".gfc Compiled GF source, will be loaded as is.",
".gfe Example-based GF source, will be converted to .gf and compiled.",
".ebnf Extended BNF format, will be converted to .gf and compiled.",
".cf Context-free (BNF) format, will be converted to .gf and compiled.",
"",
"If multiple FILES are given, they must be normal GF source, .gfc or .gfe files.",
"For the other input formats, only one file can be given.",
"",
"Command-line options:"]
helpMessage :: String
helpMessage = usageInfo usageHeader optDescr
-- Error monad
type ErrorMsg = String
data Err a = Ok a | Errors [ErrorMsg]
deriving (Read, Show, Eq)
instance Monad Err where
return = Ok
fail e = Errors [e]
Ok a >>= f = f a
Errors s >>= f = Errors s
errors :: [ErrorMsg] -> Err a
errors = Errors
-- Types
data Mode = Version | Help | Interactive | Compiler
deriving (Show,Eq,Ord)
data Phase = Preproc | Convert | Compile | Link
deriving (Show,Eq,Ord)
data Encoding = UTF_8 | ISO_8859_1
deriving (Show,Eq,Ord)
data OutputFormat = FmtGFCC | FmtJS
deriving (Show,Eq,Ord)
data Optimization = OptStem | OptCSE
deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat
deriving (Show,Eq,Ord)
data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypecheck | DumpRefresh | DumpOptimize | DumpCanon
deriving (Show,Eq,Ord)
data ModuleOptions = ModuleOptions {
optPreprocessors :: [String],
optEncoding :: Encoding,
optOptimizations :: [Optimization],
optLibraryPath :: [FilePath],
optSpeechLanguage :: Maybe String,
optBuildParser :: Bool,
optWarnings :: [Warning],
optDump :: [Dump]
}
deriving (Show)
data Options = Options {
optMode :: Mode,
optStopAfterPhase :: Phase,
optVerbosity :: Int,
optShowCPUTime :: Bool,
optEmitGFO :: Bool,
optGFODir :: FilePath,
optOutputFormats :: [OutputFormat],
optOutputName :: Maybe String,
optOutputFile :: Maybe FilePath,
optOutputDir :: FilePath,
optForceRecomp :: Bool,
optProb :: Bool,
optStartCategory :: Maybe String,
optModuleOptions :: ModuleOptions
}
deriving (Show)
-- Option parsing
parseOptions :: [String] -> Err (Options, [FilePath])
parseOptions args = case errs of
[] -> do o <- foldM (\o f -> f o) defaultOptions opts
return (o, files)
_ -> errors errs
where (opts, files, errs) = getOpt RequireOrder optDescr args
parseModuleFlags :: Options -> [(String,String)] -> Err ModuleOptions
parseModuleFlags opts flags = foldr setOpt (optModuleOptions opts) moduleOptDescr
where
setOpt (Option _ ss arg _) d
| null values = d
| otherwise = case arg of
NoArg a ->
ReqArg (String -> a) _ ->
OptArg (Maybe String -> a) String
last values
where values = [v | (k,v) <- flags, k `elem` ss ]
-- Default options
defaultModuleOptions :: ModuleOptions
defaultModuleOptions = ModuleOptions {
optPreprocessors = [],
optEncoding = ISO_8859_1,
optOptimizations = [OptStem,OptCSE],
optLibraryPath = [],
optSpeechLanguage = Nothing,
optBuildParser = True,
optWarnings = [],
optDump = []
}
defaultOptions :: Options
defaultOptions = Options {
optMode = Interactive,
optStopAfterPhase = Link,
optVerbosity = 1,
optShowCPUTime = False,
optEmitGFO = True,
optGFODir = ".",
optOutputFormats = [FmtGFCC],
optOutputName = Nothing,
optOutputFile = Nothing,
optOutputDir = ".",
optForceRecomp = False,
optProb = False,
optStartCategory = Nothing,
optModuleOptions = defaultModuleOptions
}
-- Option descriptions
moduleOptDescr :: [OptDescr (ModuleOptions -> Err ModuleOptions)]
moduleOptDescr =
[
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
Option [] ["preproc"] (ReqArg preproc "CMD")
(unlines ["Use CMD to preprocess input files.",
"Multiple preprocessors can be used by giving this option multiple times."]),
Option [] ["stem"] (onOff (optimize OptStem) True) "Perform stem-suffix analysis (default on).",
Option [] ["cse"] (onOff (optimize OptCSE) True) "Perform common sub-expression elimination (default on).",
Option [] ["parser"] (onOff parser True) "Build parser (default on).",
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar."
]
where
addLibDir x o = return $ o { optLibraryPath = x:optLibraryPath o }
setLibPath x o = return $ o { optLibraryPath = splitInModuleSearchPath x }
preproc x o = return $ o { optPreprocessors = optPreprocessors o ++ [x] }
optimize x b o = return $ o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) }
parser x o = return $ o { optBuildParser = x }
language x o = return $ o { optSpeechLanguage = Just x }
optDescr :: [OptDescr (Options -> Err Options)]
optDescr =
[
Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo.",
Option ['V'] ["version"] (NoArg (mode Version)) "Display GF version number.",
Option ['?','h'] ["help"] (NoArg (mode Help)) "Show help message.",
Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 3.",
Option ['q'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
Option [] ["batch"] (NoArg (mode Compiler)) "Run in batch compiler mode.",
Option [] ["interactive"] (NoArg (mode Interactive)) "Run in interactive mode (default).",
Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).",
Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:",
"Multiple concrete: gfcc (default), gar, js, ...",
"Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...",
"Abstract only: haskell, ..."]),
Option ['n'] ["output-name"] (ReqArg outName "NAME")
("Use NAME as the name of the output. This is used in the output file names, "
++ "with suffixes depending on the formats, and, when relevant, "
++ "internally in the output."),
Option ['o'] ["output-file"] (ReqArg outFile "FILE")
"Save output in FILE (default is out.X, where X depends on output format.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
"Save output files (other than .gfc files) in DIR.",
Option [] ["src","force-recomp"] (NoArg (forceRecomp True))
"Always recompile from source, i.e. disable recompilation checking.",
Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.",
Option [] ["startcat"] (ReqArg startcat "CAT") "Use CAT as the start category in the generated grammar."
] ++ map (fmap onModuleOptions) moduleOptDescr
where phase x o = return $ o { optStopAfterPhase = x }
mode x o = return $ o { optMode = x }
verbosity mv o = case mv of
Nothing -> return $ o { optVerbosity = 3 }
Just v -> case reads v of
[(i,"")] | i >= 0 -> return $ o { optVerbosity = i }
_ -> fail $ "Bad verbosity: " ++ show v
cpu x o = return $ o { optShowCPUTime = x }
emitGFO x o = return $ o { optEmitGFO = x }
gfoDir x o = return $ o { optGFODir = x }
outFmt x o = readOutputFormat x >>= \f ->
return $ o { optOutputFormats = optOutputFormats o ++ [f] }
outName x o = return $ o { optOutputName = Just x }
outFile x o = return $ o { optOutputFile = Just x }
outDir x o = return $ o { optOutputDir = x }
forceRecomp x o = return $ o { optForceRecomp = x }
prob x o = return $ o { optProb = x }
startcat x o = return $ o { optStartCategory = Just x }
onModuleOptions :: Monad m => (ModuleOptions -> m ModuleOptions) -> Options -> m Options
onModuleOptions f o = do mo' <- f (optModuleOptions o)
return $ o { optModuleOptions = mo' }
instance Functor OptDescr where
fmap f (Option cs ss d s) = Option cs ss (fmap f d) s
instance Functor ArgDescr where
fmap f (NoArg x) = NoArg (f x)
fmap f (ReqArg g s) = ReqArg (f . g) s
fmap f (OptArg g s) = OptArg (f . g) s
outputFormats :: [(String,OutputFormat)]
outputFormats =
[("gfcc", FmtGFCC),
("js", FmtJS)]
onOff :: Monad m => (Bool -> (a -> m a)) -> Bool -> ArgDescr (a -> m a)
onOff f def = OptArg g "[on,off]"
where g ma x = do b <- maybe (return def) readOnOff ma
f b x
readOnOff x = case map toLower x of
"on" -> return True
"off" -> return False
_ -> fail $ "Expected [on,off], got: " ++ show x
readOutputFormat :: Monad m => String -> m OutputFormat
readOutputFormat s =
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats

1
src-3.0/GF/Devel/TC.hs
View File

@@ -24,7 +24,6 @@ module GF.Devel.TC (AExp(..),
import GF.Data.Operations
import GF.Grammar.Predef
import GF.Grammar.Abstract
import GF.Devel.AbsCompute
import Control.Monad
import Data.List (sortBy)

9
src-3.0/GF/Devel/TestGF3.hs
View File

@@ -1,9 +0,0 @@
module Main where
import GF.Devel.Compile.GFC
import System (getArgs)
main = do
xx <- getArgs
mainGFC xx

212
src-3.0/GF/Devel/TypeCheck.hs
View File

@@ -13,31 +13,16 @@
-----------------------------------------------------------------------------
module GF.Devel.TypeCheck (-- * top-level type checking functions; TC should not be called directly.
annotate, annotateIn,
justTypeCheck, checkIfValidExp,
reduceConstraints,
splitConstraints,
possibleConstraints,
reduceConstraintsNode,
performMetaSubstNode,
-- * some top-level batch-mode checkers for the compiler
justTypeCheckSrc,
grammar2theorySrc,
checkContext,
checkTyp,
checkEquation,
checkConstrs,
editAsTermCommand,
exp2termCommand,
exp2termlistCommand,
tree2termlistCommand
) where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Grammar.Abstract
import GF.Devel.AbsCompute
import GF.Grammar.Refresh
import GF.Grammar.LookAbs
import qualified GF.Grammar.Lookup as Lookup ---
@@ -49,147 +34,10 @@ import GF.Grammar.Unify ---
import Control.Monad (foldM, liftM, liftM2)
import Data.List (nub) ---
-- top-level type checking functions; TC should not be called directly.
annotate :: GFCGrammar -> Exp -> Err Tree
annotate gr exp = annotateIn gr [] exp Nothing
-- | type check in empty context, return a list of constraints
justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints
justTypeCheck gr e v = do
(_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0
return $ fst $ splitConstraints gr constrs1
-- | type check in empty context, return the expression itself if valid
checkIfValidExp :: GFCGrammar -> Exp -> Err Exp
checkIfValidExp gr e = do
(_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e
constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0
ifNull (return e) (Bad . unwords . prConstrs) constrs1
annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree
annotateIn gr gamma exp = maybe (infer exp) (check exp) where
infer e = do
(a,_,cs) <- inferExp theory env e
aexp2treeC (a,cs)
check e v = do
(a,cs) <- checkExp theory env e v
aexp2treeC (a,cs)
env = initTCEnv gamma
theory = grammar2theory gr
aexp2treeC (a,c) = do
c' <- reduceConstraints (lookupAbsDef gr) (length gamma) c
aexp2tree (a,c')
-- | invariant way of creating TCEnv from context
initTCEnv gamma =
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-- | process constraints after eqVal by computing by defs
reduceConstraints :: LookDef -> Int -> Constraints -> Err Constraints
reduceConstraints look i = liftM concat . mapM redOne where
redOne (u,v) = do
u' <- computeVal look u
v' <- computeVal look v
eqVal i u' v'
computeVal :: LookDef -> Val -> Err Val
computeVal look v = case v of
VClos g@(_:_) e -> do
e' <- compt (map fst g) e --- bindings of g in e?
whnf $ VClos g e'
{- ----
_ -> do ---- how to compute a Val, really??
e <- val2exp v
e' <- compt [] e
whnf $ vClos e'
-}
VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf
_ -> whnf v
where
compt = computeAbsTermIn look
compv = computeVal look
-- | take apart constraints that have the form (? <> t), usable as solutions
splitConstraints :: GFCGrammar -> Constraints -> (Constraints,MetaSubst)
splitConstraints gr = splitConstraintsGen (lookupAbsDef gr)
splitConstraintsSrc :: Grammar -> Constraints -> (Constraints,MetaSubst)
splitConstraintsSrc gr = splitConstraintsGen (Lookup.lookupAbsDef gr)
splitConstraintsGen :: LookDef -> Constraints -> (Constraints,MetaSubst)
splitConstraintsGen look cs = csmsu where
csmsu = (nub [(a,b) | (a,b) <- csf1,a /= b],msf1)
(csf1,msf1) = unif (csf,msf) -- alternative: filter first
(csf,msf) = foldr mkOne ([],[]) cs
csmsf = foldr mkOne ([],msu) csu
(csu,msu) = unif (cs1,[]) -- alternative: unify first
cs1 = errVal cs $ reduceConstraints look 0 cs
mkOne (u,v) = case (u,v) of
(VClos g (Meta m), v) | null g -> sub m v
(v, VClos g (Meta m)) | null g -> sub m v
-- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG
c -> con c
con c (cs,ms) = (c:cs,ms)
sub m v (cs,ms) = (cs,(m,v):ms)
unifo = id -- alternative: don't use unification
unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification
(cs',ms') <- unifyVal cs
return (cs', ms' ++ ms)
performMetaSubstNode :: MetaSubst -> TrNode -> TrNode
performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let
v' = metaSubstVal v
b' = [(x,metaSubstVal v) | (x,v) <- b]
c' = [(u',v') | (u,v) <- c,
let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v']
in N (b',a,v',(c',m),s)
where
metaSubstVal u = errVal u $ whnf $ case u of
VApp f a -> VApp (metaSubstVal f) (metaSubstVal a)
VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e)
_ -> u
metaSubstExp e = case e of
Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst
_ -> composSafeOp metaSubstExp e
reduceConstraintsNode :: GFCGrammar -> TrNode -> TrNode
reduceConstraintsNode gr = changeConstrs red where
red cs = errVal cs $ reduceConstraints (lookupAbsDef gr) 0 cs
-- | weak heuristic to narrow down menus; not used for TC. 15\/11\/2001.
-- the age-old method from GF 0.9
possibleConstraints :: GFCGrammar -> Constraints -> Bool
possibleConstraints gr = and . map (possibleConstraint gr)
possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool
possibleConstraint gr (u,v) = errVal True $ do
u' <- val2exp u >>= compute gr
v' <- val2exp v >>= compute gr
return $ cts u' v'
where
cts t u = isUnknown t || isUnknown u || case (t,u) of
(Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d)
(QC m c, QC n d) -> c == d
(App f a, App g b) -> cts f g && cts a b
(Abs x b, Abs y c) -> cts b c
(Prod x a f, Prod y b g) -> cts a b && cts f g
(_ , _) -> False
isUnknown t = case t of
Vr _ -> True
Meta _ -> True
_ -> False
notCan = not . isPrimitiveFun gr
-- interface to TC type checker
type2val :: Type -> Val
@@ -227,13 +75,6 @@ aexp2tree (aexp,cs) = do
return ([],AtM m,v',[])
_ -> Bad "illegal tree" -- AProd
grammar2theory :: GFCGrammar -> Theory
grammar2theory gr (m,f) = case lookupFunType gr m f of
Ok t -> return $ type2val t
Bad s -> case lookupCatContext gr m f of
Ok cont -> return $ cont2val cont
_ -> Bad s
cont2exp :: Context -> Exp
cont2exp c = mkProd (c, eType, []) -- to check a context
@@ -242,9 +83,9 @@ cont2val = type2val . cont2exp
-- some top-level batch-mode checkers for the compiler
justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints
justTypeCheckSrc gr e v = do
(_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v
justTypeCheck :: Grammar -> Exp -> Val -> Err Constraints
justTypeCheck gr e v = do
(_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
return $ filter notJustMeta constrs0
---- return $ fst $ splitConstraintsSrc gr constrs0
---- this change was to force proper tc of abstract modules.
@@ -254,10 +95,10 @@ notJustMeta (c,k) = case (c,k) of
(VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
_ -> True
grammar2theorySrc :: Grammar -> Theory
grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of
grammar2theory :: Grammar -> Theory
grammar2theory gr (m,f) = case lookupFunType gr m f of
Ok t -> return $ type2val t
Bad s -> case lookupCatContextSrc gr m f of
Bad s -> case lookupCatContext gr m f of
Ok cont -> return $ cont2val cont
_ -> Bad s
@@ -265,47 +106,14 @@ checkContext :: Grammar -> Context -> [String]
checkContext st = checkTyp st . cont2exp
checkTyp :: Grammar -> Type -> [String]
checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType
checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType
checkEquation :: Grammar -> Fun -> Trm -> [String]
checkEquation gr (m,fun) def = err singleton id $ do
typ <- lookupFunTypeSrc gr m fun
---- cs <- checkEqs (grammar2theorySrc gr) (initTCEnv []) ((m,fun),def) (vClos typ)
cs <- justTypeCheckSrc gr def (vClos typ)
let cs1 = filter notJustMeta cs ----- filter (not . possibleConstraint gr) cs ----
typ <- lookupFunType gr m fun
cs <- justTypeCheck gr def (vClos typ)
let cs1 = filter notJustMeta cs
return $ ifNull [] (singleton . prConstraints) cs1
checkConstrs :: Grammar -> Cat -> [Ident] -> [String]
checkConstrs gr cat _ = [] ---- check constructors!
{- ----
err singleton concat . mapM checkOne where
checkOne con = do
typ <- lookupFunType gr con
typ' <- computeAbsTerm gr typ
vcat <- valCat typ'
return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con]
-}
editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp]
editAsTermCommand gr c e = err (const []) singleton $ do
t <- annotate gr $ refreshMetas [] e
t' <- c $ tree2loc t
return $ tree2exp $ loc2tree t'
exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree
exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do
let exp = tree2exp t
exp2 <- f exp
annotate gr exp2
exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree]
exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp
tree2termlistCommand :: GFCGrammar -> (Tree -> [Exp]) -> Tree -> [Tree]
tree2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f