GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

"Committed_by_peb"

Browse Source
This commit is contained in:
peb
2005-02-18 18:21:06 +00:00
parent 1c4f025320
commit 9568d7a844
149 changed files with 1518 additions and 1160 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/GF/API.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.27 $
--
-- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001
-----------------------------------------------------------------------------

6
src/GF/API/BatchTranslate.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- translate OCL, etc, files in batch mode
-----------------------------------------------------------------------------

6
src/GF/API/GrammarToHaskell.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- to write a GF abstract grammar into a Haskell module with translations from
-- data objects into GF trees. Example: GSyntax for Agda.

6
src/GF/API/IOGrammar.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.14 $
--
-- for reading grammars and terms from strings and files
-----------------------------------------------------------------------------

6
src/GF/API/MyParser.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- template to define your own parser (obsolete?)
-----------------------------------------------------------------------------

36
src/GF/CF/CF.hs
View File

@@ -1,18 +1,38 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- context-free grammars. AR 15/12/1999 -- 30/3/2000 -- 2/6/2001 -- 3/12/2001
-- context-free grammars. AR 15\/12\/1999 -- 30\/3\/2000 -- 2\/6\/2001 -- 3\/12\/2001
-----------------------------------------------------------------------------
module CF where
module CF (-- * Types
CF(..), CFRule, CFRuleGroup,
CFItem(..), CFTree(..), CFPredef, CFParser,
RegExp(..), CFWord,
-- * Functions
cfParseResults,
-- ** to construct CF grammars
emptyCF, emptyCFPredef, rules2CF, groupCFRules,
-- ** to construct rules
atomCFRule, atomCFTerm, atomRegExp, altsCFTerm,
-- ** to construct trees
atomCFTree, buildCFTree,
-- ** to decide whether a token matches a terminal item
matchCFTerm, satRegExp,
-- ** to analyse a CF grammar
catsOfCF, rulesOfCF, ruleGroupsOfCF, rulesForCFCat,
valCatCF, valItemsCF, valFunCF,
startCat, predefOfCF, appCFPredef, valCFItem,
cfTokens, wordsOfRegExp, forCFItem,
isCircularCF, predefRules
) where
import Operations
import Str
@@ -182,10 +202,10 @@ forCFItem :: CFTok -> CFRule -> Bool
forCFItem a (_,(_, CFTerm r : _)) = satRegExp r a
forCFItem _ _ = False
-- | we should make a test of circular chains, too
isCircularCF :: CFRule -> Bool
isCircularCF (_,(c', CFNonterm c:[])) = compatCF c' c
isCircularCF _ = False
--- we should make a test of circular chains, too
-- | coercion to the older predef cf type
predefRules :: CFPredef -> CFTok -> [CFRule]

44
src/GF/CF/CFIdent.hs
View File

@@ -1,18 +1,35 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CFIdent
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.10 $
--
-- symbols (categories, functions) for context-free grammars.
-----------------------------------------------------------------------------
module CFIdent where
module CFIdent (-- * Tokens and categories
CFTok(..), CFCat(..),
tS, tC, tL, tI, tV, tM, tInt,
prCFTok,
-- * Function names and profiles
CFFun(..), Profile,
wordsCFTok,
-- * CF Functions
mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun, intCFFun, dummyCFFun,
cfFun2String, cfFun2Ident, cfFun2Profile, metaCFFun,
-- * CF Categories
mkCIdent, ident2CFCat, string2CFCat, catVarCF, cat2CFCat, cfCatString, cfCatInt,
moduleOfCFCat, cfCat2Cat, cfCat2Ident, lexCFCat,
-- * CF Tokens
string2CFTok, str2cftoks,
-- * Comparisons
compatToks, compatTok, compatCFFun, compatCF
) where
import Operations
import GFC
@@ -37,7 +54,13 @@ data CFTok =
-- | this type should be abstract
newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show)
tS, tC, tL, tI, tV, tM :: String -> CFTok
tS :: String -> CFTok
tC :: String -> CFTok
tL :: String -> CFTok
tI :: String -> CFTok
tV :: String -> CFTok
tM :: String -> CFTok
tS = TS
tC = TC
tL = TL
@@ -91,8 +114,9 @@ stringCFFun = mkCFFun . AS
intCFFun :: Int -> CFFun
intCFFun = mkCFFun . AI . toInteger
-- | used in lexer-by-need rules
dummyCFFun :: CFFun
dummyCFFun = varCFFun $ identC "_" --- used in lexer-by-need rules
dummyCFFun = varCFFun $ identC "_"
cfFun2String :: CFFun -> String
cfFun2String (CFFun (f,_)) = prt f
@@ -134,7 +158,10 @@ cat2CFCat :: (Ident,Ident) -> CFCat
cat2CFCat = uncurry idents2CFCat
-- | literals
cfCatString :: CFCat
cfCatString = string2CFCat (prt cPredefAbs) "String"
cfCatInt :: CFCat
cfCatInt = string2CFCat (prt cPredefAbs) "Int"
@@ -170,6 +197,7 @@ str2cftoks = map tS . words . sstr
compatToks :: [CFTok] -> [CFTok] -> Bool
compatToks ts us = and [compatTok t u | (t,u) <- zip ts us]
compatTok :: CFTok -> CFTok -> Bool
compatTok (TM _ _) _ = True --- hack because metas are renamed
compatTok _ (TM _ _) = True
compatTok t u = any (`elem` (alts t)) (alts u) where

10
src/GF/CF/CFtoGrammar.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CFtoGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- 26\/1\/2000 -- 18\/4 -- 24\/3\/2004
-----------------------------------------------------------------------------

6
src/GF/CF/CFtoSRG.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- This module prints a CF as a SRG (Speech Recognition Grammar).
-- Created : 21 January, 2001.

10
src/GF/CF/CanonToCF.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CanonToCF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.11 $
--
-- AR 27\/1\/2000 -- 3\/12\/2001 -- 8\/6\/2003
-----------------------------------------------------------------------------

6
src/GF/CF/ChartParser.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Bottom-up Kilbury chart parser from "Pure Functional Parsing", chapter 5.
-- OBSOLETE -- should use new MCFG parsers instead

10
src/GF/CF/EBNF.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : EBNF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

10
src/GF/CF/PPrCF.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PPrCF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.9 $
--
-- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003
--

10
src/GF/CF/PrLBNF.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PrLBNF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.8 $
--
-- Printing CF grammars generated from GF as LBNF grammar for BNFC.
-- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003 -- 27/9/2004.

10
src/GF/CF/Profile.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Profile
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001
-- revised 8/4/2002 for the new profile structure

13
src/GF/CFGM/AbsCFG.hs
View File

@@ -1,16 +1,3 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module AbsCFG where

13
src/GF/CFGM/PrintCFG.hs
View File

@@ -1,16 +1,3 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module PrintCFG where

8
src/GF/CFGM/PrintCFGrammar.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Module : PrintCFGrammar
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- Handles printing a CFGrammar in CFGM format.
-----------------------------------------------------------------------------

13
src/GF/Canon/AbsGFC.hs
View File

@@ -1,16 +1,3 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module AbsGFC where

14
src/GF/Canon/CMacros.hs
View File

@@ -1,15 +1,17 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CMacros
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.20 $
--
-- Macros for building and analysing terms in GFC concrete syntax.
--
-- macros for concrete syntax in GFC that do not need lookup in a grammar
-----------------------------------------------------------------------------
module CMacros where
@@ -27,8 +29,6 @@ import Operations
import Char
import Monad
-- macros for concrete syntax in GFC that do not need lookup in a grammar
-- | how to mark subtrees, dep. on node, position, whether focus
type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String)

10
src/GF/Canon/CanonToGrammar.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CanonToGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.12 $
--
-- a decompiler. AR 12/6/2003 -- 19/4/2004
-----------------------------------------------------------------------------

21
src/GF/Canon/GFC.hs
View File

@@ -1,18 +1,27 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : GFC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- canonical GF. AR 10\/9\/2002 -- 9\/5\/2003 -- 21\/9
-----------------------------------------------------------------------------
module GFC where
module GFC (Context,
CanonGrammar,
CanonModInfo,
CanonModule,
CanonAbs,
Info(..),
Printname,
mapInfoTerms,
setFlag
) where
import AbsGFC
import PrintGFC

10
src/GF/Canon/GetGFC.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : GetGFC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

22
src/GF/Canon/Look.hs
View File

@@ -1,18 +1,28 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Look
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.11 $
--
-- lookup in GFC. AR 2003
-----------------------------------------------------------------------------
module Look where
module Look (lookupCncInfo,
lookupLin,
lookupLincat,
lookupPrintname,
lookupResInfo,
lookupGlobal,
lookupOptionsCan,
lookupParamValues,
allParamValues,
ccompute
) where
import AbsGFC
import GFC

10
src/GF/Canon/MkGFC.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : MkGFC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.11 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

10
src/GF/Canon/PrExp.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PrExp
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- print trees without qualifications
-----------------------------------------------------------------------------

13
src/GF/Canon/PrintGFC.hs
View File

@@ -1,16 +1,3 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module PrintGFC where

6
src/GF/Canon/Share.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.10 $
--
-- Optimizations on GFC code: sharing, parametrization, value sets.
--

6
src/GF/Canon/Unlex.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/17 10:22:10 $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:07 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- elementary text postprocessing. AR 21/11/2001
-----------------------------------------------------------------------------

10
src/GF/Compile/BackOpt.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : Aarne Ranta
-- Module : BackOpt
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Optimizations on GF source code: sharing, parametrization, value sets.
--

12
src/GF/Compile/CheckGrammar.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CheckGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.20 $
--
-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
--
@@ -20,7 +20,7 @@
-- - tables are type-annotated
-----------------------------------------------------------------------------
module CheckGrammar where
module CheckGrammar (showCheckModule, justCheckLTerm) where
import Grammar
import Ident

13
src/GF/Compile/Compile.hs
View File

@@ -1,18 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Compile
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.33 $
--
-- The top-level compilation chain from source file to gfc\/gfr.
-----------------------------------------------------------------------------
module Compile where
module Compile (compileModule, compileEnvShSt, compileOne
) where
import Grammar
import Ident

13
src/GF/Compile/Extend.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Extend
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.15 $
--
-- AR 14\/5\/2003 -- 11\/11
--
@@ -15,7 +15,8 @@
-- extends a module symbol table by indirections to the module it extends
-----------------------------------------------------------------------------
module Extend where
module Extend (extendModule, extendMod
) where
import Grammar
import Ident

14
src/GF/Compile/GetGrammar.hs
View File

@@ -1,18 +1,20 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : GetGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.14 $
--
-- this module builds the internal GF grammar that is sent to the type checker
-----------------------------------------------------------------------------
module GetGrammar where
module GetGrammar (getSourceModule, getOldGrammar, getCFGrammar, getEBNFGrammar,
err2err
) where
import Operations
import qualified ErrM as E ----

14
src/GF/Compile/GrammarToCanon.hs
View File

@@ -1,18 +1,20 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : GrammarToCanon
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.16 $
--
-- Code generator from optimized GF source code to GFC.
-----------------------------------------------------------------------------
module GrammarToCanon where
module GrammarToCanon (showGFC,
redModInfo, redQIdent
) where
import Operations
import Zipper

12
src/GF/Compile/MkResource.hs
View File

@@ -1,18 +1,18 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : MkResource
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.11 $
--
-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
-----------------------------------------------------------------------------
module MkResource where
module MkResource (makeReuse) where
import Grammar
import Ident

10
src/GF/Compile/MkUnion.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : MkUnion
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- building union of modules.
-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance

18
src/GF/Compile/ModDeps.hs
View File

@@ -1,20 +1,24 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : ModDeps
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.11 $
--
-- Check correctness of module dependencies. Incomplete.
--
-- AR 13/5/2003
-- AR 13\/5\/2003
-----------------------------------------------------------------------------
module ModDeps where
module ModDeps (mkSourceGrammar,
moduleDeps,
openInterfaces,
requiredCanModules
) where
import Grammar
import Ident

14
src/GF/Compile/NewRename.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : NewRename
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- AR 14/5/2003
-- AR 14\/5\/2003
--
-- The top-level function 'renameGrammar' does several things:
--
@@ -23,7 +23,7 @@
-- Hence we can proceed by @fold@ing "from left to right".
-----------------------------------------------------------------------------
module Rename where
module Rename (renameSourceTerm, renameModule) where
import Grammar
import Values

12
src/GF/Compile/Optimize.hs
View File

@@ -1,18 +1,18 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Optimize
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.13 $
--
-- Top-level partial evaluation for GF source modules.
-----------------------------------------------------------------------------
module Optimize where
module Optimize (optimizeModule) where
import Grammar
import Ident

15
src/GF/Compile/PGrammar.hs
View File

@@ -1,18 +1,21 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module PGrammar where
module PGrammar (pTerm, pTrm, pTrms,
pMeta, pzIdent,
string2ident
) where
---import LexGF
import ParGF

13
src/GF/Compile/PrOld.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PrOld
-- Maintainer : GF
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- a hack to print gf2 into gf1 readable files
-- Works only for canonical grammars, printed into GFC. Otherwise we would have
@@ -15,7 +15,7 @@
-- --- printnames are not preserved, nor are lindefs
-----------------------------------------------------------------------------
module PrOld where
module PrOld (printGrammarOld, stripTerm) where
import PrGrammar
import CanonToGrammar
@@ -59,6 +59,7 @@ stripInfo (c,i) = case i of
stripContext co = [(x, stripTerm t) | (x,t) <- co]
stripTerm :: Term -> Term
stripTerm t = case t of
Q _ c -> Vr c
QC _ c -> Vr c

12
src/GF/Compile/Rebuild.hs
View File

@@ -1,18 +1,18 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Rebuild
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.9 $
--
-- Rebuild a source module from incomplete and its with-instance.
-----------------------------------------------------------------------------
module Rebuild where
module Rebuild (rebuildModule) where
import Grammar
import ModDeps

12
src/GF/Compile/RemoveLiT.hs
View File

@@ -1,19 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : RemoveLiT
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003
--
-- What the program does is replace the occurrences of Lin C with the actual
-- definition T given in lincat C = T ; with {s : Str} if no lincat is found.
-- The procedule is uncertain, if T contains another Lin.
-- The procedure is uncertain, if T contains another Lin.
-----------------------------------------------------------------------------
module RemoveLiT (removeLiT) where

17
src/GF/Compile/Rename.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Rename
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.17 $
--
-- AR 14/5/2003
-- AR 14\/5\/2003
-- The top-level function 'renameGrammar' does several things:
--
-- - extends each module symbol table by indirections to extended module
@@ -22,7 +22,10 @@
-- Hence we can proceed by @fold@ing "from left to right".
-----------------------------------------------------------------------------
module Rename where
module Rename (renameGrammar,
renameSourceTerm,
renameModule
) where
import Grammar
import Values

10
src/GF/Compile/ShellState.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : ShellState
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.35 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

17
src/GF/Compile/Update.hs
View File

@@ -1,18 +1,23 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Update
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module Update where
module Update (updateRes, buildAnyTree, combineAnyInfos, unifyAnyInfo,
-- * these auxiliaries should be somewhere else
-- since they don't use the info types
groupInfos, sortInfos, combineInfos, unifyInfos,
tryInsert, unifAbsDefs, unifConstrs
) where
import Ident
import Grammar

15
src/GF/Data/ErrM.hs
View File

@@ -1,20 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : ErrM
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:14 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- hack for BNFC generated files. AR 21/9/2003
-----------------------------------------------------------------------------
module ErrM (
module Operations
) where
module ErrM (module Operations
) where
import Operations

10
src/GF/Data/Glue.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Glue
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:14 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@
-----------------------------------------------------------------------------

26
src/GF/Data/Map.hs
View File

@@ -5,24 +5,23 @@
-- Stability : Stable
-- Portability : Haskell 98
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module Map
(
module Map (
Map,
empty,
isEmpty,
(!), -- lookup operator.
(!+), -- lookupMany operator.
(|->), -- insert operator.
(|->+), -- insertMany operator.
(<+>), -- union operator.
flatten --
(!),
(!+),
(|->),
(|->+),
(<+>),
flatten
) where
import RedBlack
@@ -38,20 +37,25 @@ infixl 4 <+>
empty :: Map key el
empty = emptyTree
-- | lookup operator.
(!) :: Ord key => Map key el -> key -> Maybe el
fm ! e = lookupTree e fm
-- | lookupMany operator.
(!+) :: Ord key => Map key el -> [key] -> [Maybe el]
fm !+ [] = []
fm !+ (e:es) = (lookupTree e fm): (fm !+ es)
-- | insert operator.
(|->) :: Ord key => (key,el) -> Map key el -> Map key el
(x,y) |-> fm = insertTree (x,y) fm
-- | insertMany operator.
(|->+) :: Ord key => [(key,el)] -> Map key el -> Map key el
[] |->+ fm = fm
((x,y):xs) |->+ fm = xs |->+ (insertTree (x,y) fm)
-- | union operator.
(<+>) :: Ord key => Map key el -> Map key el -> Map key el
(<+>) fm1 fm2 = xs |->+ fm2
where xs = flatten fm1

136
src/GF/Data/Operations.hs
View File

@@ -1,18 +1,79 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Operations
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.15 $
--
-- (Description of the module)
-- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
--
-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
-----------------------------------------------------------------------------
module Operations where
module Operations (-- * misc functions
ifNull, onSnd,
-- * the Error monad
Err(..), err, maybeErr, testErr, errVal, errIn, derrIn,
performOps, repeatUntilErr, repeatUntil, okError, isNotError,
showBad, lookupErr, lookupErrMsg, lookupDefault, updateLookupList,
mapPairListM, mapPairsM, pairM, mapErr, mapErrN, foldErr,
(!?), errList, singleton,
-- ** checking
checkUnique, titleIfNeeded, errMsg, errAndMsg,
-- * a three-valued maybe type to express indirections
Perhaps(..), yes, may, nope,
mapP,
unifPerhaps, updatePerhaps, updatePerhapsHard,
-- * binary search trees
BinTree(..), isInBinTree, commonsInTree, justLookupTree,
lookupTree, lookupTreeEq, lookupTreeMany, updateTree,
updateTreeGen, updateTreeEq, updatesTree, updatesTreeNondestr, buildTree,
sorted2tree, mapTree, mapMTree, tree2list,
depthTree, mergeTrees,
-- * parsing
WParser, wParseResults, paragraphs,
-- * printing
indent, (+++), (++-), (++++), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-- ** LaTeX code producing functions
dollar, mbox, ital, boldf, verbat, mkLatexFile,
begindocument, enddocument,
-- * extra
sortByLongest, combinations, mkTextFile, initFilePath,
-- * topological sorting with test of cyclicity
topoTest, topoSort,
-- * the generic fix point iterator
iterFix,
-- * association lists
updateAssoc, removeAssoc,
-- * chop into separator-separated parts
chunks, readIntArg,
-- * state monad with error; from Agda 6\/11\/2001
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done,
-- * error monad class
ErrorMonad(..), checkAgain, checks, allChecks
) where
import Char (isSpace, toUpper, isSpace, isDigit)
import List (nub, sortBy, sort, deleteBy, nubBy)
@@ -24,9 +85,6 @@ infixr 5 ++++
infixr 5 +++++
infixl 9 !?
-- some auxiliary GF operations. AR 19/6/1998 -- 6/2/2001
-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
ifNull :: b -> ([a] -> b) -> [a] -> b
ifNull b f xs = if null xs then b else f xs
@@ -35,7 +93,8 @@ onSnd f (x, y) = (x, f y)
-- the Error monad
data Err a = Ok a | Bad String -- like Maybe type with error msgs
-- | like @Maybe@ type with error msgs
data Err a = Ok a | Bad String
deriving (Read, Show, Eq)
instance Monad Err where
@@ -43,17 +102,18 @@ instance Monad Err where
Ok a >>= f = f a
Bad s >>= f = Bad s
instance Functor Err where -- added 2/10/2003 by PEB
-- | added 2\/10\/2003 by PEB
instance Functor Err where
fmap f (Ok a) = Ok (f a)
fmap f (Bad s) = Bad s
-- analogue of maybe
-- | analogue of @maybe@
err :: (String -> b) -> (a -> b) -> Err a -> b
err d f e = case e of
Ok a -> f a
Bad s -> d s
-- add msg s to Maybe failures
-- | add msg s to @Maybe@ failures
maybeErr :: String -> Maybe a -> Err a
maybeErr s = maybe (Bad s) Ok
@@ -66,7 +126,7 @@ errVal a = err (const a) id
errIn :: String -> Err a -> Err a
errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return
-- used for extra error reports when developing GF
-- | used for extra error reports when developing GF
derrIn :: String -> Err a -> Err a
derrIn m = errIn m -- id
@@ -121,14 +181,14 @@ mapPairsM f xys =
pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c)
pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
-- like mapM, but continue instead of halting with Err
-- | like @mapM@, but continue instead of halting with 'Err'
mapErr :: (a -> Err b) -> [a] -> Err ([b], String)
mapErr f xs = Ok (ys, unlines ss)
where
(ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs])
fxs = map f xs
-- alternative variant, peb 9/6-04
-- | alternative variant, peb 9\/6-04
mapErrN :: Int -> (a -> Err b) -> [a] -> Err ([b], String)
mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2))
where
@@ -139,8 +199,7 @@ mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2))
nss = length ss
fxs = map f xs
-- like foldM, but also return the latest value if fails
-- | like @foldM@, but also return the latest value if fails
foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String)
foldErr f s xs = case xs of
[] -> return (s,Nothing)
@@ -148,7 +207,7 @@ foldErr f s xs = case xs of
Ok v -> foldErr f v xx
Bad m -> return $ (s, Just m)
-- !! with the error monad
-- @!!@ with the error monad
(!?) :: [a] -> Int -> Err a
xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs
@@ -177,8 +236,7 @@ errAndMsg :: Err a -> Err (a,[String])
errAndMsg (Bad m) = Bad m
errAndMsg (Ok a) = return (a,[])
-- a three-valued maybe type to express indirections
-- | a three-valued maybe type to express indirections
data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord)
yes = Yes
@@ -191,7 +249,7 @@ mapP f p = case p of
May b -> May b
Nope -> Nope
-- this is what happens when matching two values in the same module
-- | this is what happens when matching two values in the same module
unifPerhaps :: (Eq a, Eq b, Show a, Show b) =>
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
unifPerhaps p1 p2 = case (p1,p2) of
@@ -200,7 +258,7 @@ unifPerhaps p1 p2 = case (p1,p2) of
_ -> if p1==p2 then return p1
else Bad ("update conflict between" ++++ show p1 ++++ show p2)
-- this is what happens when updating a module extension
-- | this is what happens when updating a module extension
updatePerhaps :: (Eq a,Eq b, Show a, Show b) =>
b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
updatePerhaps old p1 p2 = case (p1,p2) of
@@ -209,7 +267,7 @@ updatePerhaps old p1 p2 = case (p1,p2) of
(_, May a) -> Bad "strange indirection"
_ -> unifPerhaps p1 p2
-- here the value is copied instead of referred to; used for oper types
-- | here the value is copied instead of referred to; used for oper types
updatePerhapsHard :: (Eq a, Eq b, Show a, Show b) => b ->
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
updatePerhapsHard old p1 p2 = case (p1,p2) of
@@ -230,9 +288,9 @@ isInBinTree x tree = case tree of
| x > a -> isInBinTree x right
| x == a -> True
-- quick method to see if two trees have common elements
-- | quick method to see if two trees have common elements
--
-- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller
commonsInTree :: (Ord a) => BinTree (a,b) -> BinTree (a,b) -> [(a,(b,b))]
commonsInTree old new = foldr inOld [] new' where
new' = tree2list new
@@ -266,13 +324,11 @@ lookupTreeMany pr (t:ts) x = case lookupTree pr x t of
_ -> lookupTreeMany pr ts x
lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x
-- destructive update
-- | destructive update
updateTree :: (Ord a) => (a,b) -> BinTree (a,b) -> BinTree (a,b)
updateTree = updateTreeGen True
-- destructive or not
-- | destructive or not
updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree (a,b) -> BinTree (a,b)
updateTreeGen destr z@(x,y) tree = case tree of
NT -> BT z NT NT
@@ -419,8 +475,7 @@ prIfEmpty :: String -> String -> String -> String -> String
prIfEmpty em _ _ [] = em
prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2
-- Thomas Hallgren's wrap lines
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
-- | Thomas Hallgren's wrap lines
wrapLines n "" = ""
wrapLines n s@(c:cs) =
if isSpace c
@@ -433,6 +488,8 @@ wrapLines n s@(c:cs) =
l = length w
_ -> s -- give up!!
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
-- LaTeX code producing functions
dollar s = '$' : s ++ "$"
@@ -468,8 +525,8 @@ sortByLongest = sortBy longer where
x' = length x
y' = length y
-- "combinations" is the same as "sequence"!!!
-- peb 30/5-04
-- | 'combinations' is the same as @sequence@!!!
-- peb 30\/5-04
combinations :: [[a]] -> [[a]]
combinations t = case t of
[] -> [[]]
@@ -527,8 +584,7 @@ topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where
inDeg f = length [t | (h,hs) <- g, t <- hs, t == f]
lx = length g
-- the generic fix point iterator
-- | the generic fix point iterator
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
iterFix more start = iter start start
where
@@ -549,8 +605,7 @@ updateAssoc ab@(a,b) as = case as of
removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)]
removeAssoc a = filter ((/=a) . fst)
-- chop into separator-separated parts
-- | chop into separator-separated parts
chunks :: String -> [String] -> [[String]]
chunks sep ws = case span (/= sep) ws of
(a,_:b) -> a : bs where bs = chunks sep b
@@ -608,7 +663,8 @@ instance ErrorMonad (STM s) where
handle (STM f) g = STM (\s -> (f s)
`handle` (\e -> let STM g' = (g e) in
g' s))
-- if the first check fails try another one
-- | if the first check fails try another one
checkAgain :: ErrorMonad m => m a -> m a -> m a
checkAgain c1 c2 = handle_ c1 c2

10
src/GF/Data/OrdMap2.hs
View File

@@ -5,16 +5,16 @@
-- Stability : Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- The class of finite maps, as described in
-- "Pure Functional Parsing", section 2.2.2
-- \"Pure Functional Parsing\", section 2.2.2
-- and an example implementation,
-- derived from appendix A.2
--
-- /OBSOLETE/! this is only used in cf\/ChartParser.hs
-- /OBSOLETE/! this is only used in module "ChartParser"
-----------------------------------------------------------------------------
module OrdMap2 (OrdMap(..), Map) where

10
src/GF/Data/OrdSet.hs
View File

@@ -5,16 +5,16 @@
-- Stability : Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- The class of ordered sets, as described in
-- "Pure Functional Parsing", section 2.2.1,
-- \"Pure Functional Parsing\", section 2.2.1,
-- and an example implementation
-- derived from appendix A.1
--
-- /OBSOLETE/! this is only used in cf\/ChartParser.hs
-- /OBSOLETE/! this is only used in module "ChartParser"
-----------------------------------------------------------------------------
module OrdSet (OrdSet(..), Set) where

27
src/GF/Data/Parsers.hs
View File

@@ -5,16 +5,31 @@
-- Stability : Almost Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- some parser combinators a` la Wadler and Hutton
-- some parser combinators a la Wadler and Hutton.
-- no longer used in many places in GF
-- (only used in EBNF.hs)
-- (only used in module "EBNF")
-----------------------------------------------------------------------------
module Parsers where
module Parsers (-- * Main types and functions
Parser, parseResults, parseResultErr,
-- * Basic combinators (on any token type)
(...), (.>.), (|||), (+||), literal, (***),
succeed, fails, (+..), (..+), (<<<), (|>),
many, some, longestOfMany, longestOfSome,
closure,
-- * Specific combinators (for @Char@ token type)
pJunk, pJ, jL, pTList, pTJList, pElem,
(....), item, satisfy, literals, lits,
pParenth, pCommaList, pOptCommaList,
pArgList, pArgList2,
pIdent, pLetter, pDigit, pLetters,
pAlphanum, pAlphaPlusChar,
pQuotedString, pIntc
) where
import Operations
import Char

6
src/GF/Data/RedBlack.hs
View File

@@ -5,9 +5,9 @@
-- Stability : Stable
-- Portability : Haskell 98
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Modified version of Osanaki's implementation.
-----------------------------------------------------------------------------

13
src/GF/Data/SharedString.hs
View File

@@ -1,16 +1,3 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module SharedString (shareString) where

32
src/GF/Data/Str.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Str
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -23,23 +23,23 @@ module Str (
import Operations
import List (isPrefixOf, isSuffixOf, intersperse)
-- abstract token list type. AR 2001, revised and simplified 20/4/2003
-- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003
newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord)
data Tok =
TK String
| TN Ss [(Ss, [String])] -- variants depending on next string
| TN Ss [(Ss, [String])] -- ^ variants depending on next string
--- | TP Ss [(Ss, [String])] -- variants depending on previous string
deriving (Eq, Ord, Show, Read)
-- notice that having both pre and post would leave to inconsistent situations:
-- pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
-- ^ notice that having both pre and post would leave to inconsistent situations:
--
-- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
--
-- always violates a condition expressed by the one or the other
-- a variant can itself be a token list, but for simplicity only a list of strings
-- i.e. not itself containing variants
-- | a variant can itself be a token list, but for simplicity only a list of strings
-- i.e. not itself containing variants
type Ss = [String]
-- matching functions in both ways
@@ -80,8 +80,7 @@ str2allStrings (Str st) = alls st where
sstr :: Str -> String
sstr = unwords . str2strings
-- to handle a list of variants
-- | to handle a list of variants
sstrV :: [Str] -> String
sstrV ss = case ss of
[] -> "*"
@@ -127,8 +126,7 @@ glues ss tt = case (ss,tt) of
(_,[]) -> ss
_ -> init ss ++ [last ss ++ head tt] ++ tail tt
-- to create the list of all lexical items
-- | to create the list of all lexical items
allItems :: Str -> [String]
allItems (Str s) = concatMap allOne s where
allOne t = case t of

8
src/GF/Data/Trie.hs
View File

@@ -2,12 +2,12 @@
-- |
-- Module : Trie
-- Maintainer : Markus Forsberg
-- Stability : Obsolete???
-- Stability : Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

6
src/GF/Data/Trie2.hs
View File

@@ -5,9 +5,9 @@
-- Stability : Stable
-- Portability : Haskell 98
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

61
src/GF/Data/Zipper.hs
View File

@@ -1,18 +1,57 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Zipper
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- Gérard Huet's zipper (JFP 7 (1997)). AR 10/8/2001
-- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
-----------------------------------------------------------------------------
module Zipper where
module Zipper (-- * types
Tr(..),
Path(..),
Loc(..),
-- * basic (original) functions
leaf,
goLeft, goRight, goUp, goDown,
changeLoc,
changeNode,
forgetNode,
-- * added sequential representation
goAhead,
goBack,
-- ** n-ary versions
goAheadN,
goBackN,
-- * added mappings between locations and trees
loc2tree,
loc2treeMarked,
tree2loc,
goRoot,
goLast,
goPosition,
-- * added some utilities
traverseCollect,
scanTree,
mapTr,
mapTrM,
mapPath,
mapPathM,
mapLoc,
mapLocM,
foldTr,
foldTrM,
mapSubtrees,
mapSubtreesM,
changeRoot,
nthSubtree,
arityTree
) where
import Operations
@@ -56,7 +95,7 @@ forgetNode _ = Bad $ "not a one-branch tree"
-- added sequential representation
-- a successor function
-- | a successor function
goAhead :: Loc a -> Err (Loc a)
goAhead s@(Loc (t,p)) = case (t,p) of
(Tr (_,_:_),Node (_,_,_:_)) -> goDown s
@@ -67,7 +106,7 @@ goAhead s@(Loc (t,p)) = case (t,p) of
Ok t' -> return t'
Bad _ -> goUp t >>= upsRight
-- a predecessor function
-- | a predecessor function
goBack :: Loc a -> Err (Loc a)
goBack s@(Loc (t,p)) = case goLeft s of
Ok s' -> downRight s'
@@ -183,7 +222,7 @@ mapSubtreesM f t = do
ts' <- mapM (mapSubtreesM f) ts
return $ Tr (x, ts')
-- change the root without moving the pointer
-- | change the root without moving the pointer
changeRoot :: (a -> a) -> Loc a -> Loc a
changeRoot f loc = case loc of
Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top)
@@ -197,4 +236,4 @@ nthSubtree :: Int -> Tr a -> Err (Tr a)
nthSubtree n (Tr (a,ts)) = ts !? n
arityTree :: Tr a -> Int
arityTree (Tr (_,ts)) = length ts
arityTree (Tr (_,ts)) = length ts

6
src/GF/Fudgets/ArchEdit.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:10 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

6
src/GF/Fudgets/CommandF.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

19
src/GF/Fudgets/EventF.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : EventF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:14 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -15,12 +15,13 @@
module EventF where
import AllFudgets
-- The first string is the name of the key (e.g., "Down" for the down arrow key)
-- | The first string is the name of the key (e.g., "Down" for the down arrow key)
--
-- The modifiers list shift, control and alt keys that were active while the
-- key was pressed.
--
-- The last string is the text produced by the key (for keys that produce
-- printable characters, empty for control keys).
type KeyPress = ((String,[Modifiers]),String)
keyboardF :: F i o -> F i (Either KeyPress o)
@@ -34,10 +35,10 @@ keyboardF fud = idRightSP (concatMapSP post) >^^=< oeventF mask fud
EnterWindowMask, LeaveWindowMask -- because of CTT implementation
]
-- Output events:
-- | Output events:
oeventF em fud = eventF em (idLeftF fud)
-- Feed events to argument fudget:
-- | Feed events to argument fudget:
eventF eventmask = serCompLeftToRightF . groupF startcmds eventK
where
startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask],

16
src/GF/Fudgets/FudgetOps.hs
View File

@@ -1,23 +1,21 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : FudgetOps
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:14 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- (Description of the module)
-- auxiliary Fudgets for GF syntax editor
-----------------------------------------------------------------------------
module FudgetOps where
import Fudgets
-- auxiliary Fudgets for GF syntax editor
-- save and display
showAndSaveF fud = (writeFileF >+< textWindowF) >==< saveF fud
@@ -35,7 +33,7 @@ saveSP contents = getSP $ \msg -> case msg of
textWindowF = writeOutputF
-- to replace stringInputF by a pop-up slot behind a button
-- | to replace stringInputF by a pop-up slot behind a button
popupStringInputF :: String -> String -> String -> F String String
popupStringInputF label deflt msg =
mapF snd

12
src/GF/Fudgets/UnicodeF.hs
View File

@@ -1,18 +1,18 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : UnicodeF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module UnicodeF where
module UnicodeF (fudlogueWriteU) where
import Fudgets
import Operations

26
src/GF/Grammar/AbsCompute.hs
View File

@@ -1,18 +1,25 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : AbsCompute
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-- computation in abstract syntax w.r.t. explicit definitions.
--
-- old GF computation; to be updated
-----------------------------------------------------------------------------
module AbsCompute where
module AbsCompute (LookDef,
compute,
computeAbsTerm,
computeAbsTermIn,
beta
) where
import Operations
@@ -24,16 +31,13 @@ import Compute
import Monad (liftM, liftM2)
-- computation in abstract syntax w.r.t. explicit definitions.
--- old GF computation; to be updated
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
-- | a hack to make compute work on source grammar as well
type LookDef = Ident -> Ident -> Err (Maybe Term)
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp

10
src/GF/Grammar/Abstract.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Abstract
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

13
src/GF/Grammar/AppPredefined.hs
View File

@@ -1,18 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : AppPredefined
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.9 $
--
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
module AppPredefined where
module AppPredefined (isInPredefined, typPredefined, appPredefined
) where
import Operations
import Grammar

20
src/GF/Grammar/Compute.hs
View File

@@ -1,18 +1,18 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Compute
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.13 $
--
-- Computation of source terms. Used in compilation and in 'cc' command.
-- Computation of source terms. Used in compilation and in @cc@ command.
-----------------------------------------------------------------------------
module Compute where
module Compute (computeConcrete, computeTerm) where
import Operations
import Grammar
@@ -31,9 +31,8 @@ import AppPredefined
import List (nub,intersperse)
import Monad (liftM2, liftM)
-- computation of concrete syntax terms into normal form
-- | computation of concrete syntax terms into normal form
-- used mainly for partial evaluation
computeConcrete :: SourceGrammar -> Term -> Err Term
computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t
@@ -295,8 +294,7 @@ computeTerm gr = comp where
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
return $ S (T i cs') e
-- argument variables cannot be glued
-- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term
checkNoArgVars t = case t of
Vr (IA _) -> Bad $ glueErrorMsg $ prt t

201
src/GF/Grammar/Grammar.hs
View File

@@ -1,18 +1,54 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Grammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- GF source abstract syntax used internally in compilation.
--
-- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
-----------------------------------------------------------------------------
module Grammar where
module Grammar (SourceGrammar,
SourceModInfo,
SourceModule,
SourceAbs,
SourceRes,
SourceCnc,
Info(..),
Perh,
MPr,
Type,
Cat,
Fun,
QIdent,
Term(..),
Patt(..),
TInfo(..),
Label(..),
MetaSymb(..),
Decl,
Context,
Equation,
Labelling,
Assign,
Case,
Cases,
LocalDef,
Param,
Altern,
Substitution,
Branch(..),
Con,
Trm,
wildPatt,
varLabel
) where
import Str
import Ident
@@ -21,10 +57,7 @@ import Modules
import Operations
-- AR 23/1/2000 -- 30/5/2001 -- 4/5/2003
-- grammar as presented to the compiler
-- | grammar as presented to the compiler
type SourceGrammar = MGrammar Ident Option Info
type SourceModInfo = ModInfo Ident Option Info
@@ -35,29 +68,39 @@ type SourceAbs = Module Ident Option Info
type SourceRes = Module Ident Option Info
type SourceCnc = Module Ident Option Info
-- judgements in abstract syntax
-- | the constructors are judgements in
--
-- - abstract syntax (/ABS/)
--
-- - resource (/RES/)
--
-- - concrete syntax (/CNC/)
--
-- and indirection to module (/INDIR/)
data Info =
AbsCat (Perh Context) (Perh [Term]) -- constructors; must be Id or QId
| AbsFun (Perh Type) (Perh Term) -- Yes f = canonical
| AbsTrans Term
-- judgements in abstract syntax
AbsCat (Perh Context) (Perh [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
| AbsFun (Perh Type) (Perh Term) -- ^ (/ABS/) 'Yes f' = canonical
| AbsTrans Term -- ^ (/ABS/)
-- judgements in resource
| ResParam (Perh [Param])
| ResValue (Perh Type) -- to mark parameter constructors for lookup
| ResOper (Perh Type) (Perh Term)
| ResParam (Perh [Param]) -- ^ (/RES/)
| ResValue (Perh Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Perh Type) (Perh Term) -- ^ (/RES/)
-- judgements in concrete syntax
| CncCat (Perh Type) (Perh Term) MPr -- lindef ini'zed,
| CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- type info added at TC
| CncCat (Perh Type) (Perh Term) MPr -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- (/CNC/) type info added at 'TC'
-- indirection to module Ident; the Bool says if canonical
| AnyInd Bool Ident
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving (Read, Show)
type Perh a = Perhaps a Ident -- to express indirection to other module
-- | to express indirection to other module
type Perh a = Perhaps a Ident
type MPr = Perhaps Term Ident -- printname
-- | printname
type MPr = Perhaps Term Ident
type Type = Term
type Cat = QIdent
@@ -66,80 +109,81 @@ type Fun = QIdent
type QIdent = (Ident,Ident)
data Term =
Vr Ident -- variable
| Cn Ident -- constant
| Con Ident -- constructor
| EData -- to mark in definition that a fun is a constructor
| Sort String -- basic type
| EInt Int -- integer literal
| K String -- string literal or token: "foo"
| Empty -- the empty string []
Vr Ident -- ^ variable
| Cn Ident -- ^ constant
| Con Ident -- ^ constructor
| EData -- ^ to mark in definition that a fun is a constructor
| Sort String -- ^ basic type
| EInt Int -- ^ integer 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}
| 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 only for concrete syntax
| RecType [Labelling] -- record type: { p : A ; ...}
| R [Assign] -- record: { p = a ; ...}
| P Term Label -- projection: r.p
| ExtR Term Term -- extension: R ** {x : A} (both types and terms)
| Typed Term Term -- ^ type-annotated term
--
-- /below this, the constructors are only for concrete syntax/
| RecType [Labelling] -- ^ record type: @{ p : A ; ...}@
| R [Assign] -- ^ record: @{ p = a ; ...}@
| P Term Label -- ^ projection: @r.p@
| 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 ; ...}
| TSh TInfo [Cases] -- table with discjunctive patters (only back end opt)
| V Type [Term] -- table given as course of values: table T [c1 ; ... ; cn]
| S Term Term -- selection: t ! p
| Table Term Term -- ^ table type: @P => A@
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@
| TSh TInfo [Cases] -- ^ table with discjunctive patters (only back end opt)
| V Type [Term] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
| S Term Term -- ^ selection: @t ! p@
| Let LocalDef Term -- local definition: let {t : T = a} in b
| Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
| Alias Ident Type Term -- constant and its definition, used in inlining
| Alias Ident Type Term -- ^ constant and its definition, used in inlining
| Q Ident Ident -- qualified constant from a package
| QC Ident Ident -- qualified constructor from a package
| Q Ident Ident -- ^ qualified constant from a package
| QC Ident Ident -- ^ qualified constructor from a package
| C Term Term -- concatenation: s ++ t
| Glue Term Term -- agglutination: s + t
| C Term Term -- ^ concatenation: @s ++ t@
| Glue Term Term -- ^ agglutination: @s + t@
| FV [Term] -- alternatives in free variation: variants { s ; ... }
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
| Alts (Term, [(Term, Term)]) -- alternatives by prefix: pre {t ; s/c ; ...}
| Strs [Term] -- conditioning prefix strings: strs {s ; ...}
--- these three are obsolete
| LiT Ident -- linearization type
| Ready Str -- result of compiling; not to be parsed ...
| Computed Term -- result of computing: not to be reopened nor parsed
| Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
--
-- /below this, the last three constructors are obsolete/
| LiT Ident -- ^ linearization type
| Ready Str -- ^ result of compiling; not to be parsed ...
| Computed Term -- ^ result of computing: not to be reopened nor parsed
deriving (Read, Show, Eq, Ord)
data Patt =
PC Ident [Patt] -- constructor pattern: C p1 ... pn C
| PP Ident Ident [Patt] -- package constructor pattern: P.C p1 ... pn P.C
| PV Ident -- variable pattern: x
| PW -- wild card pattern: _
| PR [(Label,Patt)] -- record pattern: {r = p ; ...} -- only concrete
| PString String -- string literal pattern: "foo" -- only abstract
| PInt Int -- integer literal pattern: 12 -- only abstract
| PT Type Patt -- type-annotated pattern
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@
| PP Ident Ident [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@
| PV Ident -- ^ variable pattern: @x@
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
| PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
| PInt Int -- ^ integer literal pattern: @12@ -- only abstract
| PT Type Patt -- ^ type-annotated pattern
deriving (Read, Show, Eq, Ord)
-- to guide computation and type checking of tables
-- | to guide computation and type checking of tables
data TInfo =
TRaw -- received from parser; can be anything
| TTyped Type -- type annontated, but can be anything
| TComp Type -- expanded
| TWild Type -- just one wild card pattern, no need to expand
TRaw -- ^ received from parser; can be anything
| TTyped Type -- ^ type annontated, 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) -- record label
deriving (Read, Show, Eq, Ord)
newtype MetaSymb = MetaSymb Int deriving (Read, Show, Eq, Ord)
@@ -158,10 +202,11 @@ type Altern = (Term, [(Term, Term)])
type Substitution = [(Ident, Term)]
-- branches à la Alfa
-- | branches à la Alfa
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
wildPatt :: Patt

14
src/GF/Grammar/Lockfield.hs
View File

@@ -1,15 +1,17 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Lockfield
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Creating and using lock fields in reused resource grammars.
--
-- AR 8\/2\/2005 detached from 'compile/MkResource'
-----------------------------------------------------------------------------
module Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
@@ -21,8 +23,6 @@ import PrGrammar
import Operations
-- AR 8/2/2005 detached from compile/MkResource
lockRecType :: Ident -> Type -> Err Type
lockRecType c t@(RecType rs) =
let lab = lockLabel c in

41
src/GF/Grammar/LookAbs.hs
View File

@@ -1,18 +1,35 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : LookAbs
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.12 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module LookAbs where
module LookAbs (GFCGrammar,
lookupAbsDef,
lookupFunType,
lookupCatContext,
lookupTransfer,
isPrimitiveFun,
lookupRef,
refsForType,
funRulesOf,
allCatsOf,
allBindCatsOf,
funsForType,
funsOnType,
funsOnTypeFs,
allDefs,
lookupFunTypeSrc,
lookupCatContextSrc
) where
import Operations
import qualified GFC as C
@@ -62,8 +79,7 @@ lookupCatContext gr m c = errIn ("looking up context of cat" +++ prt c) $ do
_ -> prtBad "unknown category" c
_ -> Bad $ prt m +++ "is not an abstract module"
-- lookup for transfer function: transfer-module-name, category name
-- | lookup for transfer function: transfer-module-name, category name
lookupTransfer :: GFCGrammar -> Ident -> Ident -> Err Term
lookupTransfer gr m c = errIn ("looking up transfer of cat" +++ prt c) $ do
mi <- lookupModule gr m
@@ -77,7 +93,7 @@ lookupTransfer gr m c = errIn ("looking up transfer of cat" +++ prt c) $ do
_ -> Bad $ prt m +++ "is not a transfer module"
---- should be revised (20/9/2003)
-- | should be revised (20\/9\/2003)
isPrimitiveFun :: GFCGrammar -> Fun -> Bool
isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of
Ok (Just (Eqs [])) -> True -- is canonical
@@ -85,8 +101,7 @@ isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of
_ -> True -- has no definition
-- looking up refinement terms
-- | looking up refinement terms
lookupRef :: GFCGrammar -> Binds -> Term -> Err Val
lookupRef gr binds at = case at of
Q m f -> lookupFunType gr m f >>= return . vClos
@@ -147,8 +162,7 @@ allDefs gr = [((i,c),d) | (i, ModMod m) <- modules gr,
isModAbs m,
(c, C.AbsFun _ d) <- tree2list (jments m)]
-- this is needed at compile time
-- | this is needed at compile time
lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type
lookupFunTypeSrc gr m c = do
mi <- lookupModule gr m
@@ -161,6 +175,7 @@ lookupFunTypeSrc gr m c = do
_ -> prtBad "cannot find type of" c
_ -> Bad $ prt m +++ "is not an abstract module"
-- | this is needed at compile time
lookupCatContextSrc :: Grammar -> Ident -> Ident -> Err Context
lookupCatContextSrc gr m c = do
mi <- lookupModule gr m

25
src/GF/Grammar/Lookup.hs
View File

@@ -1,18 +1,29 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Lookup
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.12 $
--
-- Lookup in source (concrete and resource) when compiling.
--
-- lookup in resource and concrete in compiling; for abstract, use 'Look'
-----------------------------------------------------------------------------
module Lookup where
module Lookup (lookupResDef,
lookupResType,
lookupParams,
lookupParamValues,
lookupFirstTag,
allParamValues,
lookupAbsDef,
lookupLincat,
opersForType
) where
import Operations
import Abstract
@@ -22,8 +33,6 @@ import Lockfield
import List (nub)
import Monad
-- lookup in resource and concrete in compiling; for abstract, use Look
lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
lookupResDef gr = look True where
look isTop m c = do

26
src/GF/Grammar/MMacros.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : MMacros
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-- some more abstractions on grammars, esp. for Edit
-----------------------------------------------------------------------------
module MMacros where
@@ -27,8 +27,6 @@ import Macros
import Monad
-- some more abstractions on grammars, esp. for Edit
nodeTree (Tr (n,_)) = n
argsTree (Tr (_,ts)) = ts
@@ -69,7 +67,7 @@ changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
------ on the way to Edit
-- * on the way to Edit
uTree :: Tree
uTree = Tr (uNode, []) -- unknown tree
@@ -139,7 +137,7 @@ substTerm ss g c = case c of
metaSubstExp :: MetaSubst -> [(Meta,Exp)]
metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
-- belong here rather than to computation
-- * belong here rather than to computation
substitute :: [Var] -> Substitution -> Exp -> Err Exp
substitute v s = return . substTerm v s
@@ -245,7 +243,7 @@ fun2wrap oldvars ((fun,i),typ) exp = do
let vars = mkFreshVars (length cont) oldvars
return $ mkAbs vars $ if n==i then exp else mExp
-- weak heuristics: sameness of value category
-- | weak heuristics: sameness of value category
compatType :: Val -> Type -> Bool
compatType v t = errVal True $ do
cat1 <- val2cat v
@@ -269,8 +267,7 @@ identVar (Vr x) = return x
identVar _ = Bad "not a variable"
-- light-weight rename for user interaction; also change names of internal vars
-- | light-weight rename for user interaction; also change names of internal vars
qualifTerm :: Ident -> Term -> Term
qualifTerm m = qualif [] where
qualif xs t = case t of
@@ -287,8 +284,7 @@ string2var s = case s of
c:'_':i -> identV (readIntArg i,[c]) ---
_ -> zIdent s
-- reindex variables so that they tell nesting depth level
-- | reindex variables so that they tell nesting depth level
reindexTerm :: Term -> Term
reindexTerm = qualif (0,[]) where
qualif dg@(d,g) t = case t of

54
src/GF/Grammar/Macros.hs
View File

@@ -1,15 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Macros
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.17 $
--
-- Macros for constructing and analysing source code terms.
--
-- operations on terms and types not involving lookup in or reference to grammars
--
-- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001
-----------------------------------------------------------------------------
module Macros where
@@ -23,10 +27,6 @@ import PrGrammar
import Monad (liftM)
import Char (isDigit)
-- AR 7/12/1999 - 9/5/2000 -- 4/6/2001
-- operations on terms and types not involving lookup in or reference to grammars
firstTypeForm :: Type -> Err (Context, Type)
firstTypeForm t = case t of
Prod x a b -> do
@@ -366,7 +366,7 @@ varX i = identV (i,"x")
mkFreshVar :: [Ident] -> Ident
mkFreshVar olds = varX (maxVarIndex olds + 1)
-- trying to preserve a given symbol
-- | trying to preserve a given symbol
mkFreshVarX :: [Ident] -> Ident -> Ident
mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
@@ -376,22 +376,22 @@ maxVarIndex = maximum . ((-1):) . map varIndex
mkFreshVars :: Int -> [Ident] -> [Ident]
mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
--- quick hack for refining with var in editor
-- | quick hack for refining with var in editor
freshAsTerm :: String -> Term
freshAsTerm s = Vr (varX (readIntArg s))
-- create a terminal for concrete syntax
-- | create a terminal for concrete syntax
string2term :: String -> Term
string2term = ccK
ccK = K
ccC = C
-- create a terminal from identifier
-- | create a terminal from identifier
ident2terminal :: Ident -> Term
ident2terminal = ccK . prIdent
-- create a constant
-- | create a constant
string2CnTrm :: String -> Term
string2CnTrm = Cn . zIdent
@@ -441,7 +441,7 @@ mkFreshMetasInTrm metas = fst . rms minMeta where
_ -> (trm,meta)
minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
-- decides that a term has no metavariables
-- | decides that a term has no metavariables
isCompleteTerm :: Term -> Bool
isCompleteTerm t = case t of
Meta _ -> False
@@ -492,7 +492,7 @@ redirectTerm n t = case t of
Q _ f -> Q n f
_ -> composSafeOp (redirectTerm n) t
-- to gather s-fields; assumes term in normal form, preserves label
-- | to gather s-fields; assumes term in normal form, preserves label
allLinFields :: Term -> Err [[(Label,Term)]]
allLinFields trm = case unComputed trm of
---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
@@ -502,24 +502,24 @@ allLinFields trm = case unComputed trm of
return $ concat lts
_ -> prtBad "fields can only be sought in a record not in" trm
---- deprecated
-- | deprecated
isLinLabel l = case l of
LIdent ('s':cs) | all isDigit cs -> True
_ -> False
-- to gather ultimate cases in a table; preserves pattern list
-- | to gather ultimate cases in a table; preserves pattern list
allCaseValues :: Term -> [([Patt],Term)]
allCaseValues trm = case unComputed trm of
T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
_ -> [([],trm)]
-- to gather all linearizations; assumes normal form, preserves label and args
-- | to gather all linearizations; assumes normal form, preserves label and args
allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
allLinValues trm = do
lts <- allLinFields trm
mapM (mapPairsM (return . allCaseValues)) lts
-- to mark str parts of fields in a record f by a function f
-- | to mark str parts of fields in a record f by a function f
markLinFields :: (Term -> Term) -> Term -> Term
markLinFields f t = case t of
R r -> R $ map mkField r
@@ -530,7 +530,7 @@ markLinFields f t = case t of
T i cs -> T i [(p, mkTbl v) | (p,v) <- cs]
_ -> f t
-- to get a string from a term that represents a sequence of terminals
-- | to get a string from a term that represents a sequence of terminals
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case unComputed t of
K s -> return [str s]
@@ -558,13 +558,12 @@ strsFromTerm t = case unComputed t of
Alias _ _ d -> strsFromTerm d --- should not be needed...
_ -> prtBad "cannot get Str from term" t
-- to print an Str-denoting term as a string; if the term is of wrong type, the error msg
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String
stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
-- to define compositional term functions
-- | to define compositional term functions
composSafeOp :: (Term -> Term) -> Term -> Term
composSafeOp op trm = case composOp (mkMonadic op) trm of
Ok t -> t
@@ -572,6 +571,7 @@ composSafeOp op trm = case composOp (mkMonadic op) trm of
where
mkMonadic f = return . f
-- | to define compositional term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm =
case trm of
@@ -686,8 +686,7 @@ collectOp co trm = case trm of
Strs tt -> concatMap co tt
_ -> [] -- covers K, Vr, Cn, Sort, Ready
-- to find the word items in a term
-- | to find the word items in a term
wordsInTerm :: Term -> [String]
wordsInTerm trm = filter (not . null) $ case trm of
K s -> [s]
@@ -705,8 +704,7 @@ defaultLinType = mkRecType linLabel [typeStr]
metaTerms :: [Term]
metaTerms = map (Meta . MetaSymb) [0..]
-- from GF1, 20/9/2003
-- | from GF1, 20\/9\/2003
isInOneType :: Type -> Bool
isInOneType t = case t of
Prod _ a b -> a == b

21
src/GF/Grammar/PatternMatch.hs
View File

@@ -1,18 +1,21 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PatternMatch
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
-----------------------------------------------------------------------------
module PatternMatch where
module PatternMatch (matchPattern,
testOvershadow,
findMatch
) where
import Operations
import Grammar
@@ -23,8 +26,6 @@ import PrGrammar
import List
import Monad
-- pattern matching for both concrete and abstract syntax. AR -- 16/6/2003
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
matchPattern pts term =
@@ -105,7 +106,7 @@ varsOfPatt p = case p of
PT _ q -> varsOfPatt q
_ -> []
-- to search matching parameter combinations in tables
-- | to search matching parameter combinations in tables
isMatchingForms :: [Patt] -> [Term] -> Bool
isMatchingForms ps ts = all match (zip ps ts') where
match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds

64
src/GF/Grammar/PrGrammar.hs
View File

@@ -1,18 +1,36 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PrGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.11 $
--
-- (Description of the module)
-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003
--
-- printing and prettyprinting class
--
-- 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 PrGrammar where
module PrGrammar (Print(..),
prtBad,
prGrammar, prModule,
prContext, prParam,
prQIdent, prQIdent_,
prRefinement, prTermOpt,
prt_Tree, prMarkedTree, prTree,
tree2string, prprTree,
prConstrs, prConstraints,
prMetaSubst, prEnv, prMSubst,
prExp, prPatt, prOperSignature
) where
import Operations
import Zipper
@@ -30,15 +48,14 @@ import Str
import List (intersperse)
-- AR 7/12/1999 - 1/4/2000 - 10/5/2003
-- printing and prettyprinting class
class Print a where
prt :: a -> String
prt2 :: a -> String -- printing with parentheses, if needed
prpr :: a -> [String] -- pretty printing
prt_ :: a -> String -- printing without ident qualifications
-- | 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
@@ -48,11 +65,14 @@ class Print a where
--- 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
-- | to show terms etc in error messages
prtBad :: Print a => String -> a -> Err b
prtBad s a = Bad (s +++ prt a)
prGrammar :: SourceGrammar -> String
prGrammar = P.printTree . trGrammar
prModule :: (Ident, SourceModInfo) -> String
prModule = P.printTree . trModule
instance Print Term where
@@ -108,7 +128,7 @@ 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
-- | we cannot define the method prt_ in this way
prt_Tree :: Tree -> String
prt_Tree = prt_ . tree2exp
@@ -133,7 +153,8 @@ prMarkedTree = prf 1 where
prTree :: Tree -> [String]
prTree = prMarkedTree . mapTr (\n -> (n,False))
-- a pretty-printer for parsable output
-- | a pretty-printer for parsable output
tree2string :: Tree -> String
tree2string = unlines . prprTree
prprTree :: Tree -> [String]
@@ -204,8 +225,7 @@ prQIdent (m,f) = prt m ++ "." ++ prt f
prQIdent_ :: QIdent -> String
prQIdent_ (_,f) = prt f
-- print terms without qualifications
-- | print terms without qualifications
prExp :: Term -> String
prExp e = case e of
App f a -> pr1 f +++ pr2 a
@@ -232,10 +252,12 @@ prPatt p = case p of
A.PC _ (_:_) -> prParenth $ prPatt p
_ -> prPatt p
-- option -strip strips qualifications
-- | 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
-- | 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)

14
src/GF/Grammar/Refresh.hs
View File

@@ -1,18 +1,20 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Refresh
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module Refresh where
module Refresh (refreshTerm, refreshTermN,
refreshModule
) where
import Operations
import Grammar

18
src/GF/Grammar/ReservedWords.hs
View File

@@ -1,25 +1,23 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : ReservedWords
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-- reserved words of GF. (c) Aarne Ranta 19\/3\/2002 under Gnu GPL.
-- modified by Markus Forsberg 9\/4.
-- modified by AR 12\/6\/2003 for GF2 and GFC
-----------------------------------------------------------------------------
module ReservedWords (isResWord, isResWordGFC) where
import List
-- reserved words of GF. (c) Aarne Ranta 19/3/2002 under Gnu GPL
-- modified by Markus Forsberg 9/4.
-- modified by AR 12/6/2003 for GF2 and GFC
isResWord :: String -> Bool
isResWord s = isInTree s resWordTree

22
src/GF/Grammar/TC.hs
View File

@@ -1,18 +1,24 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : TC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-- Thierry Coquand's type checking algorithm that creates a trace
-----------------------------------------------------------------------------
module TC where
module TC (AExp(..),
Theory,
checkExp,
inferExp,
eqVal,
whnf
) where
import Operations
import Abstract
@@ -20,8 +26,6 @@ import AbsCompute
import Monad
-- Thierry Coquand's type checking algorithm that creates a trace
data AExp =
AVr Ident Val
| ACn QIdent Val

44
src/GF/Grammar/TypeCheck.hs
View File

@@ -1,18 +1,37 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : TypeCheck
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.13 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module TypeCheck where
module 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 Operations
import Zipper
@@ -35,14 +54,14 @@ import List (nub) ---
annotate :: GFCGrammar -> Exp -> Err Tree
annotate gr exp = annotateIn gr [] exp Nothing
-- type check in empty context, return a list of constraints
-- | 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
-- | 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
@@ -63,11 +82,11 @@ annotateIn gr gamma exp = maybe (infer exp) (check exp) where
c' <- reduceConstraints (lookupAbsDef gr) (length gamma) c
aexp2tree (a,c')
-- invariant way of creating TCEnv from context
-- | 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
-- | 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
@@ -92,7 +111,7 @@ computeVal look v = case v of
compt = computeAbsTermIn look
compv = computeVal look
-- take apart constraints that have the form (? <> t), usable as solutions
-- | take apart constraints that have the form (? <> t), usable as solutions
splitConstraints :: GFCGrammar -> Constraints -> (Constraints,MetaSubst)
splitConstraints gr = splitConstraintsGen (lookupAbsDef gr)
@@ -141,10 +160,11 @@ performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let
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
-- | 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)

22
src/GF/Grammar/Unify.hs
View File

@@ -1,18 +1,21 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Unify
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- (Description of the module)
-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
--
-- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
-- the only use is in 'TypeCheck.splitConstraints'
-----------------------------------------------------------------------------
module Unify where
module Unify (unifyVal) where
import Abstract
@@ -20,11 +23,6 @@ import Operations
import List (partition)
-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
-- brute-force adaptation of the old-GF program AR 21/12/2001 ---
-- the only use is in TypeCheck.splitConstraints
unifyVal :: Constraints -> Err (Constraints,MetaSubst)
unifyVal cs0 = do
let (cs1,cs2) = partition notSolvable cs0

34
src/GF/Grammar/Values.hs
View File

@@ -1,18 +1,27 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Values
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module Values where
module Values (-- * values used in TC type checking
Exp, Val(..), Env,
-- * annotated tree used in editing
Tree, TrNode(..), Atom(..), Binds, Constraints, MetaSubst,
-- * for TC
valAbsInt, valAbsString, vType,
isPredefCat,
cType, cPredefAbs, cInt, cString,
eType, tree2exp, loc2treeFocus
) where
import Operations
import Zipper
@@ -45,19 +54,28 @@ type MetaSubst = [(MetaSymb,Val)]
-- for TC
valAbsInt, valAbsString :: Val
valAbsInt :: Val
valAbsInt = VCn (cPredefAbs, cInt)
valAbsString :: Val
valAbsString = VCn (cPredefAbs, cString)
vType :: Val
vType = VType
cType,cPredefAbs,cInt,cString :: Ident
cType :: Ident
cType = identC "Type" --- #0
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
cInt :: Ident
cInt = identC "Int"
cString :: Ident
cString = identC "String"
isPredefCat :: Ident -> Bool
isPredefCat c = elem c [cInt,cString]
eType :: Exp

15
src/GF/Infra/CheckM.hs
View File

@@ -1,18 +1,23 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Module : CheckM
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module CheckM where
module CheckM (Check,
checkError, checkCond, checkWarn, checkUpdate, checkInContext,
checkUpdates, checkReset, checkResets, checkGetContext,
checkLookup, checkStart, checkErr, checkVal, checkIn,
prtFail
) where
import Operations
import Grammar

13
src/GF/Infra/Comments.hs
View File

@@ -1,22 +1,21 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Module : Comments
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:13 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-- comment removal
-----------------------------------------------------------------------------
module Comments ( remComments
) where
-- | comment removal : line tails prefixed by -- as well as chunks in {- ... -}
-- | comment removal : line tails prefixed by -- as well as chunks in @{- ... -}@
remComments :: String -> String
remComments s =
case s of

24
src/GF/Infra/Ident.hs
View File

@@ -1,18 +1,26 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Ident
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:14 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module Ident where
module Ident (-- * Identifiers
Ident(..), prIdent,
identC, identV, identA, identAV, identW,
argIdent, strVar, wildIdent, isWildIdent,
newIdent, mkIdent, varIndex,
-- * refreshing identifiers
IdState, initIdStateN, initIdState,
lookVar, refVar, refVarPlus
) where
import Operations
-- import Monad
@@ -23,8 +31,8 @@ import Operations
data Ident =
IC String -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard
-- below this line: internal representation never returned by the parser
--
-- below this constructor: internal representation never returned by the parser
| IV (Int,String) -- ^ /INTERNAL/ variable
| IA (String,Int) -- ^ /INTERNAL/ argument of cat at position
| IAV (String,Int,Int) -- ^ /INTERNAL/ argument of cat with bindings at position

82
src/GF/Infra/Modules.hs
View File

@@ -1,18 +1,39 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Modules
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.19 $
--
-- Datastructures and functions for modules, common to GF and GFC.
--
-- AR 29\/4\/2003
--
-- The same structure will be used in both source code and canonical.
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
-----------------------------------------------------------------------------
module Modules where
module Modules (MGrammar(..), ModInfo(..), Module(..), ModuleType(..), MReuseType(..),
extendm, updateMGrammar, updateModule, replaceJudgements,
addOpenQualif, flagsModule, allFlags, mapModules,
MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
oSimple, oQualif,
ModuleStatus(..),
openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendsPlus, allExtensions, searchPathModule, addModule,
emptyMGrammar, emptyModInfo, emptyModule,
IdentM(..),
typeOfModule, abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupModMod, lookupInfo,
allModMod, isModAbs, isModRes, isModCnc, isModTrans,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources, greatestResource, allConcretes
) where
import Ident
import Option
@@ -46,25 +67,23 @@ data Module i f a = Module {
}
deriving Show
-- encoding the type of the module
-- | encoding the type of the module
data ModuleType i =
MTAbstract
| MTTransfer (OpenSpec i) (OpenSpec i)
| MTResource
| MTConcrete i
-- up to this, also used in GFC. Below, source only.
-- ^ up to this, also used in GFC. Below, source only.
| MTInterface
| MTInstance i
| MTReuse (MReuseType i)
| MTUnion (ModuleType i) [(i,[i])] --- not meant to be recursive
| MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive
deriving (Eq,Show)
data MReuseType i = MRInterface i | MRInstance i i | MRResource i
deriving (Show,Eq)
-- previously: single inheritance
-- | previously: single inheritance
extendm :: Module i f a -> Maybe i
extendm m = case extends m of
[i] -> Just i
@@ -72,7 +91,7 @@ extendm m = case extends m of
-- destructive update
--- dep order preserved since old cannot depend on new
-- | dep order preserved since old cannot depend on new
updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a
updateMGrammar old new = MGrammar $
[(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
@@ -114,8 +133,8 @@ data MainGrammar i = MainGrammar {
data MainConcreteSpec i = MainConcreteSpec {
concretePrintname :: i ,
concreteName :: i ,
transferIn :: Maybe (OpenSpec i) , -- if there is an in-transfer
transferOut :: Maybe (OpenSpec i) -- if there is an out-transfer
transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer
transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer
}
deriving Show
@@ -147,7 +166,7 @@ allOpens m = case mtype m of
MTTransfer a b -> a : b : opens m
_ -> opens m
-- initial dependency list
-- | initial dependency list
depPathModule :: Ord i => Module i f a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m where
fors m = case mtype m of
@@ -157,7 +176,7 @@ depPathModule m = fors m ++ exts m ++ opens m where
_ -> []
exts m = map oSimple $ extends m
-- all dependencies
-- | all dependencies
allDepsModule :: Ord i => MGrammar i f a -> Module i f a -> [OpenSpec i]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
@@ -165,7 +184,7 @@ allDepsModule gr m = iterFix add os0 where
m <- depPathModule n]
mods = modules gr
-- select just those modules that a given one depends on, including itself
-- | select just those modules that a given one depends on, including itself
partOfGrammar :: Ord i => MGrammar i f a -> (i,ModInfo i f a) -> MGrammar i f a
partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
where
@@ -175,7 +194,7 @@ partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
_ -> [i] ---- ModWith?
-- all modules that a module extends, directly or indirectly
-- | all modules that a module extends, directly or indirectly
allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
allExtends gr i = case lookupModule gr i of
Ok (ModMod m) -> case extends m of
@@ -183,7 +202,7 @@ allExtends gr i = case lookupModule gr i of
is -> i : concatMap (allExtends gr) is
_ -> []
-- this plus that an instance extends its interface
-- | this plus that an instance extends its interface
allExtendsPlus :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
allExtendsPlus gr i = case lookupModule gr i of
Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m)
@@ -191,7 +210,7 @@ allExtendsPlus gr i = case lookupModule gr i of
where
exts m = extends m ++ [j | MTInstance j <- [mtype m]]
-- conversely: all modules that extend a given module, incl. instances of interface
-- | conversely: all modules that extend a given module, incl. instances of interface
allExtensions :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
allExtensions gr i = case lookupModule gr i of
Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es
@@ -201,11 +220,11 @@ allExtensions gr i = case lookupModule gr i of
|| elem (MTInstance i) [mtype m]]
mods = [(j,m) | (j,ModMod m) <- modules gr]
-- initial search path: the nonqualified dependencies
-- | initial search path: the nonqualified dependencies
searchPathModule :: Ord i => Module i f a -> [i]
searchPathModule m = [i | OSimple _ i <- depPathModule m]
-- a new module can safely be added to the end, since nothing old can depend on it
-- | a new module can safely be added to the end, since nothing old can depend on it
addModule :: Ord i =>
MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a
addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
@@ -219,8 +238,7 @@ emptyModInfo = ModMod emptyModule
emptyModule :: Module i f a
emptyModule = Module MTResource MSComplete [] [] [] NT
-- we store the module type with the identifier
-- | we store the module type with the identifier
data IdentM i = IdentM {
identM :: i ,
typeM :: ModuleType i
@@ -310,38 +328,38 @@ sameMType m n = case (m,n) of
(MTInterface,MTResource) -> True
_ -> m == n
-- don't generate code for interfaces and for incomplete modules
-- | don't generate code for interfaces and for incomplete modules
isCompilableModule m = case m of
ModMod m -> case mtype m of
MTInterface -> False
_ -> mstatus m == MSComplete
_ -> False ---
-- interface and "incomplete M" are not complete
-- | interface and "incomplete M" are not complete
isCompleteModule :: (Eq i) => Module i f a -> Bool
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
-- all abstract modules
-- | all abstract modules
allAbstracts :: Eq i => MGrammar i f a -> [i]
allAbstracts gr = [i | (i,ModMod m) <- modules gr, mtype m == MTAbstract]
-- the last abstract in dependency order (head of list)
-- | the last abstract in dependency order (head of list)
greatestAbstract :: Eq i => MGrammar i f a -> Maybe i
greatestAbstract gr = case allAbstracts gr of
[] -> Nothing
a:_ -> return a
-- all resource modules
-- | all resource modules
allResources :: MGrammar i f a -> [i]
allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m]
-- the greatest resource in dependency order
-- | the greatest resource in dependency order
greatestResource :: MGrammar i f a -> Maybe i
greatestResource gr = case allResources gr of
[] -> Nothing
a -> return $ head a
-- all concretes for a given abstract
-- | all concretes for a given abstract
allConcretes :: Eq i => MGrammar i f a -> i -> [i]
allConcretes gr a = [i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a]

81
src/GF/Infra/Option.hs
View File

@@ -1,18 +1,72 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Option
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.19 $
--
-- Options and flags used in GF shell commands and files.
--
-- The types 'Option' and 'Options' should be kept abstract, but:
--
-- - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource"
--
-- - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
-----------------------------------------------------------------------------
module Option where
module Option (-- * all kinds of options, should be kept abstract
Option(..), Options(..), OptFun, OptFunId,
noOptions, iOpt, aOpt, iOpts, oArg, oElem, eqOpt,
getOptVal, getOptInt, optIntOrAll, optIntOrN, optIntOrOne,
changeOptVal, addOption, addOptions, concatOptions,
removeOption, removeOptions, options, unionOptions,
-- * parsing options, with prefix pre (e.g. \"-\")
getOptions, pOption, isOption,
-- * printing options, without prefix
prOpt, prOpts,
-- * a suggestion for option names
-- ** parsing
strictParse, forgiveParse, ignoreParse, literalParse,
rawParse, firstParse, dontParse,
-- ** grammar formats
showAbstr, showXML, showOld, showLatex, showFullForm,
showEBNF, showCF, showWords, showOpts,
isCompiled, isHaskell, noCompOpers, retainOpers, defaultGrOpts,
newParser, noCF, checkCirc, noCheckCirc, lexerByNeed,
-- ** linearization
allLin, firstLin, distinctLin, dontLin, showRecord, showStruct,
xmlLin, latexLin, tableLin, defaultLinOpts, useUTF8, showLang, withMetas,
-- ** other
beVerbose, showInfo, beSilent, emitCode, getHelp, doMake, doBatch,
notEmitCode, makeMulti, beShort, wholeGrammar, makeFudget, byLines, byWords,
analMorpho, doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
stripQualif, nostripQualif, showAll, fromSource,
-- ** mainly for stand-alone
useUnicode, optCompute, optCheck, optParaphrase, forJava,
-- ** for edit session
allLangs, absView,
-- ** options that take arguments
useTokenizer, useUntokenizer, useParser, withFun, firstCat, gStartCat,
useLanguage, useResource, speechLanguage, useFont,
grammarFormat, grammarPrinter, filterString, termCommand, transferFun,
forForms, menuDisplay, sizeDisplay, typeDisplay,
noDepTypes, extractGr, pathList, uniCoding,
useName, useAbsName, useCncName, useResName, useFile, useOptimizer,
markLin, markOptXML, markOptJava, markOptStruct, markOptFocus,
-- ** refinement order
nextRefine, firstRefine, lastRefine,
-- ** Boolean flags
flagYes, flagNo, caseYesNo,
-- ** integer flags
flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees
) where
import List (partition)
import Char (isDigit)
@@ -25,11 +79,20 @@ newtype Options = Opts [Option] deriving (Eq,Show,Read)
noOptions :: Options
noOptions = Opts []
iOpt o = Opt (o,[]) -- simple option -o
aOpt o a = Opt (o,[a]) -- option with argument -o=a
iOpt :: String -> Option
iOpt o = Opt (o,[])
-- ^ simple option -o
aOpt :: String -> String -> Option
aOpt o a = Opt (o,[a])
-- ^ option with argument -o=a
iOpts :: [Option] -> Options
iOpts = Opts
oArg s = s -- value of option argument
oArg :: String -> String
oArg s = s
-- ^ value of option argument
oElem :: Option -> Options -> Bool
oElem o (Opts os) = elem o os

43
src/GF/Infra/ReadFiles.hs
View File

@@ -1,26 +1,28 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : ReadFiles
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.19 $
--
-- 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.gfc@ or @file.gfr@ otherwise.
-----------------------------------------------------------------------------
module ReadFiles
--- where
--
(
--
getAllFiles,fixNewlines,ModName,getOptionsFromFile,
--
gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile) where
module ReadFiles (-- * Heading 1
getAllFiles,fixNewlines,ModName,getOptionsFromFile,
-- * Heading 2
gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile
) where
import Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
@@ -34,12 +36,6 @@ import Monad
import List
import Directory
-- 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.gfc or file.gfr otherwise.
type ModName = String
type ModEnv = [(ModName,ModTime)]
@@ -292,15 +288,14 @@ 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
-- | options can be passed to the compiler by comments in @--#@, in the main file
getOptionsFromFile :: FilePath -> IO Options
getOptionsFromFile file = do
s <- readFileIf file
let ls = filter (isPrefixOf "--#") $ lines s
return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls
-- check if old GF file
-- | check if old GF file
isOldFile :: FilePath -> IO Bool
isOldFile f = do
s <- readFileIf f
@@ -312,7 +307,7 @@ isOldFile f = do
-- old GF tolerated newlines in quotes. No more supported!
-- | old GF tolerated newlines in quotes. No more supported!
fixNewlines :: String -> String
fixNewlines s = case s of
'"':cs -> '"':mk cs

69
src/GF/Infra/UseIO.hs
View File

@@ -1,18 +1,60 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : UseIO
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module UseIO where
module UseIO (prOptCPU,
putCPU,
putPoint,
putPoint',
readFileIf,
FileName,
InitPath,
FullPath,
getFilePath,
readFileIfPath,
doesFileExistPath,
extendPathEnv,
pFilePaths,
prefixPathName,
justInitPath,
nameAndSuffix,
unsuffixFile, fileBody,
fileSuffix,
justFileName,
suffixFile,
justModuleName,
getLineWell,
putStrFlush,
putStrLnFlush,
-- * a generic quiz session
QuestionsAndAnswers,
teachDialogue,
-- * IO monad with error; adapted from state monad
IOE(..),
appIOE,
ioe,
ioeIO,
ioeErr,
ioeBad,
useIOE,
foldIOE,
putStrLnE,
putStrE,
putPointE,
putPointEVerb,
readFileIOE,
readFileLibraryIOE
) where
import Operations
import Arch (prCPU)
@@ -35,7 +77,7 @@ putIfVerbW opts msg =
then putStr (' ' : msg)
else return ()
-- obsolete with IOE monad
-- | obsolete with IOE monad
errIO :: a -> Err a -> IO a
errIO = errOptIO noOptions
@@ -95,7 +137,7 @@ doesFileExistPath paths file = do
mpfile <- ioeIO $ getFilePath paths file
return $ maybe False (const True) mpfile
-- path in environment variable has lower priority
-- | path in environment variable has lower priority
extendPathEnv :: String -> [FilePath] -> IO [FilePath]
extendPathEnv var ps = do
s <- catch (getEnv var) (const (return ""))
@@ -243,7 +285,7 @@ putPointE opts msg act = do
return a
-}
-- forces verbosity
-- | forces verbosity
putPointEVerb :: Options -> String -> IOE a -> IOE a
putPointEVerb opts = putPointE (addOption beVerbose opts)
@@ -252,9 +294,10 @@ readFileIOE :: FilePath -> IOE (String)
readFileIOE f = ioe $ catch (readFile f >>= return . return)
(\_ -> return (Bad (reportOn f))) where
reportOn f = "File " ++ f ++ " not found."
-- like readFileIOE but look also in the GF library if file not found
-- intended semantics: if file is not found, try $GF_LIB_PATH/file
-- | like readFileIOE but look also in the GF library if file not found
--
-- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@
-- (even if file is an absolute path, but this should always fail)
-- it returns not only contents of the file, but also the path used
readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String)
@@ -281,7 +324,7 @@ readFileLibraryIOE ini f =
_ -> ini ++ file -- relative path name
-- example
-- | example
koeIOE :: IO ()
koeIOE = useIOE () $ do
s <- ioeIO $ getLine

6
src/GF/Shell.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.32 $
--
-- GF shell command interpreter.
-----------------------------------------------------------------------------

6
src/GF/Shell/CommandL.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.13 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

6
src/GF/Shell/Commands.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.34 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

6
src/GF/Shell/JGF.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.9 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

6
src/GF/Shell/PShell.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.17 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

6
src/GF/Shell/ShellCommands.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.22 $
--
-- The datatype of shell commands and the list of their options.
-----------------------------------------------------------------------------

6
src/GF/Shell/SubShell.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

6
src/GF/Shell/TeachYourself.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

13
src/GF/Source/AbsGF.hs
View File

@@ -1,16 +1,3 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module AbsGF where

14
src/GF/Source/GrammarToSource.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : GrammarToSource
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.16 $
--
-- From internal source syntax to BNFC-generated (used for printing).
-----------------------------------------------------------------------------
@@ -21,9 +21,9 @@ import Option
import qualified AbsGF as P
import Ident
-- AR 13/5/2003
-- | AR 13\/5\/2003
--
-- translate internal to parsable and printable source
trGrammar :: SourceGrammar -> P.Grammar
trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes

Some files were not shown because too many files have changed in this diff Show More