From 3d74432c54c14ed1d7e4eaf777ffcaa085dbe9a6 Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 4 Dec 2007 15:01:01 +0000 Subject: [PATCH] printing new source format --- src/GF/Devel/Compile/Compile.hs | 215 ++++++++++++++++++++++++++ src/GF/Devel/Compile/GetGrammar.hs | 55 +++++++ src/GF/Devel/Grammar/GFtoSource.hs | 221 +++++++++++++++++++++++++++ src/GF/Devel/Grammar/Modules.hs | 11 ++ src/GF/Devel/Grammar/PrGF.hs | 235 +++++++++++++++++++++++++++++ src/GF/Devel/TestGF3.hs | 31 ++-- 6 files changed, 748 insertions(+), 20 deletions(-) create mode 100644 src/GF/Devel/Compile/Compile.hs create mode 100644 src/GF/Devel/Compile/GetGrammar.hs create mode 100644 src/GF/Devel/Grammar/GFtoSource.hs create mode 100644 src/GF/Devel/Grammar/PrGF.hs diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs new file mode 100644 index 000000000..78dbfec82 --- /dev/null +++ b/src/GF/Devel/Compile/Compile.hs @@ -0,0 +1,215 @@ +module GF.Devel.Compile.Compile (batchCompile) where + +-- the main compiler passes +import GF.Devel.Compile.GetGrammar +----import GF.Compile.Update +----import GF.Compile.Extend +----import GF.Compile.Rebuild +----import GF.Compile.Rename +----import GF.Grammar.Refresh +----import GF.Devel.CheckGrammar +----import GF.Devel.Optimize +--import GF.Compile.Evaluate ---- +----import GF.Devel.OptimizeGF + +import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Judgements +import GF.Infra.Ident +import GF.Infra.CompactPrint +import GF.Devel.Grammar.PrGF +----import GF.Grammar.Lookup +import GF.Devel.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 then + ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) + else return () + +prMod :: SourceModule -> String +prMod = compactPrint . prModule + +-- | environment variable for grammar search path +gfGrammarPathVar = "GF_GRAMMAR_PATH" + +-- | 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 = justInitPath file + ps0 <- ioeIO $ pathListOpts opts fpath + + let ps1 = if (useFileOpt && not useLineOpt) + then (ps0 ++ map (prefixPathName fpath) ps0) + else ps0 + ps <- ioeIO $ extendPathEnv gfLibraryPath gfGrammarPathVar 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 justFileName 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 fileBody 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 = fileSuffix file + let path = justInitPath file + let name = fileBody 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 + +{- ---- + "gfo" -> do + sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file + let sm1 = unsubexpModule sm0 + sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 + extendCompileEnv env sm +-} + -- for gf source, do full compilation and generate code + _ -> do + + let modu = unsuffixFile 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 +---- cm <- putpp " generating code... " $ generateModuleCode opts path sm1 +---- -- 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) + return (k,mo) ---- + +{- ---- + let putp = putPointE opts + putpp = putPointEsil opts + mos = modules gr + + mo1 <- ioeErr $ rebuildModule mos mo + intermOut opts (iOpt "show_rebuild") (prMod mo1) + + mo1b <- ioeErr $ extendModule mos mo1 + intermOut opts (iOpt "show_extend") (prMod mo1b) + + case mo1b of + (_,ModMod n) | not (isCompleteModule n) -> do + return (k,mo1b) -- refresh would fail, since not renamed + _ -> do + mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b + intermOut opts (iOpt "show_rename") (prMod mo2) + + (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 + if null warnings then return () else putp warnings $ return () + intermOut opts (iOpt "show_typecheck") (prMod mo3) + + + (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 + intermOut opts (iOpt "show_refresh") (prMod mo3r) + + let eenv = () --- emptyEEnv + (mo4,eenv') <- + ---- if oElem "check_only" opts + putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r + return (k',mo4) + where + ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug + prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo] + +generateModuleCode :: Options -> InitPath -> SourceModule -> IOE SourceModule +generateModuleCode opts path minfo@(name,info) = do + + let pname = prefixPathName path (prt name) + let minfo0 = minfo + let minfo1 = subexpModule minfo0 + let minfo2 = minfo1 + + let (file,out) = (gfoFile pname, prGrammar (MGrammar [minfo2])) + putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out + + return minfo2 + where + putp = putPointE opts + putpp = putPointEsil opts +-} + +-- auxiliaries + +pathListOpts :: Options -> FileName -> IO [InitPath] +pathListOpts opts file = return $ maybe [file] pFilePaths $ 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) + + diff --git a/src/GF/Devel/Compile/GetGrammar.hs b/src/GF/Devel/Compile/GetGrammar.hs new file mode 100644 index 000000000..493a35de2 --- /dev/null +++ b/src/GF/Devel/Compile/GetGrammar.hs @@ -0,0 +1,55 @@ +---------------------------------------------------------------------- +-- | +-- 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.Modules +----import GF.Devel.PrGrammar +import GF.Devel.Grammar.SourceToGF +---- import Macros +---- import Rename +--- import Custom +import GF.Devel.Grammar.ParGF +import qualified GF.Devel.Grammar.LexGF as L + +import GF.Data.Operations +import qualified GF.Devel.Grammar.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 + diff --git a/src/GF/Devel/Grammar/GFtoSource.hs b/src/GF/Devel/Grammar/GFtoSource.hs new file mode 100644 index 000000000..b49d9ee2f --- /dev/null +++ b/src/GF/Devel/Grammar/GFtoSource.hs @@ -0,0 +1,221 @@ +module GF.Devel.Grammar.GFtoSource ( + trGrammar, + trModule, + trAnyDef, + trLabel, + trt, + tri, + trp + ) where + + +import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Macros (contextOfType) +import qualified GF.Devel.Grammar.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) + body = P.MBody + (trExtends (mextends mo)) + (mkOpens (map trOpen (mopens mo))) + (concatMap trAnyDef [(c,j) | (c,Left 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) | + (c,co) <- [(k,contextOfType t) | (k,t) <- contextOfType (jtype ju)] + ] + ]] + 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]] +{- + ---- encoding of AnyInd without changing syntax. AR 20/9/2007 + AnyInd s b -> + [P.DefOper [P.DDef [mkName i] + (P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]] +-} + + +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) + + 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 + + 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 + _ -> error $ "not yet" +++ show trm ---- + +trp :: Patt -> P.Patt +trp p = case p of + 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 + diff --git a/src/GF/Devel/Grammar/Modules.hs b/src/GF/Devel/Grammar/Modules.hs index 0d3d96114..a2845e08f 100644 --- a/src/GF/Devel/Grammar/Modules.hs +++ b/src/GF/Devel/Grammar/Modules.hs @@ -20,6 +20,14 @@ data GF = 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)} + data Module = Module { mtype :: ModuleType, minterfaces :: [(Ident,Ident)], -- non-empty for functors @@ -33,6 +41,9 @@ data Module = Module { emptyModule :: Ident -> Module emptyModule m = Module MTGrammar [] [] [] [] empty empty +isCompleteModule :: Module -> Bool +isCompleteModule = Prelude.null . minterfaces + listJudgements :: Module -> [(Ident,Either Judgement Indirection)] listJudgements = assocs . mjments diff --git a/src/GF/Devel/Grammar/PrGF.hs b/src/GF/Devel/Grammar/PrGF.hs new file mode 100644 index 000000000..0a8134a6c --- /dev/null +++ b/src/GF/Devel/Grammar/PrGF.hs @@ -0,0 +1,235 @@ +---------------------------------------------------------------------- +-- | +-- 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.Grammar.PrintGF as P +import GF.Devel.Grammar.GFtoSource +import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Terms +----import GF.Grammar.Values + +----import GF.Infra.Option +import GF.Infra.Ident +----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. + +-- | 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 = P.printTree . trGrammar + +prModule :: SourceModule -> String +prModule = P.printTree . trModule + +instance Print Term where + prt = P.printTree . trt +---- prt_ = prExp + +instance Print Ident where + prt = P.printTree . 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) +-} diff --git a/src/GF/Devel/TestGF3.hs b/src/GF/Devel/TestGF3.hs index d8aad44d1..5d869de14 100644 --- a/src/GF/Devel/TestGF3.hs +++ b/src/GF/Devel/TestGF3.hs @@ -1,30 +1,21 @@ module Main where -import GF.Devel.Grammar.LexGF -import GF.Devel.Grammar.ParGF ----- import GF.Devel.Grammar.PrintGF -import GF.Devel.Grammar.Modules +import GF.Devel.Compile.Compile -import GF.Devel.Grammar.SourceToGF - -import qualified GF.Devel.Grammar.ErrM as GErr ---- import GF.Data.Operations +import GF.Infra.Option ---- -import Data.Map import System (getArgs) main = do - f:_ <- getArgs - s <- readFile f - let tt = myLexer s - case pGrammar tt of - GErr.Bad s -> putStrLn s - GErr.Ok g -> compile g + xx <- getArgs + mainGFC xx -compile g = do - let eg = transGrammar g - case eg of - Ok gr -> print (length (assocs (gfmodules gr))) >> putStrLn "OK" - Bad s -> putStrLn s - return () +mainGFC :: [String] -> IO () +mainGFC xx = do + let (opts,fs) = getOptions "-" xx + case opts of + _ -> do + mapM_ (batchCompile opts) (map return fs) + putStrLn "Done."