printing new source format

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)
+
+

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
+

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
+

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
 

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)
+-}

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."