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

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

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

472
src-3.0/GF/API.hs
View File

@@ -1,472 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : API
-- Maintainer : Aarne Ranta
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:40 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.39 $
--
-- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001
-----------------------------------------------------------------------------
module GF.API where
import qualified GF.Source.AbsGF as GF
import qualified GF.Canon.AbsGFC as A
import qualified GF.Compile.Rename as R
import GF.UseGrammar.GetTree
import GF.Canon.GFC
--- import qualified Values as V
import GF.Grammar.Values
-----import GetGrammar
import GF.Compile.Compile
import GF.API.IOGrammar
import GF.UseGrammar.Linear
import GF.UseGrammar.Parsing
import GF.UseGrammar.Morphology
import GF.CF.PPrCF
import GF.CF.CFIdent
import GF.Compile.PGrammar
import GF.UseGrammar.Randomized (mkRandomTree)
import GF.Grammar.MMacros
import qualified GF.Grammar.Macros as M
import GF.Grammar.TypeCheck
import GF.Canon.CMacros
import GF.UseGrammar.Transfer
import qualified GF.UseGrammar.Generate as Gen
import GF.Text.Text (untokWithXML)
import GF.Infra.Option
import GF.UseGrammar.Custom
import GF.Compile.ShellState
import GF.UseGrammar.Linear
import GF.Canon.GFC
import qualified GF.Grammar.Grammar as G
import GF.Infra.Modules
import GF.Grammar.PrGrammar
import qualified GF.Grammar.Compute as Co
import qualified GF.Grammar.AbsCompute as AC
import qualified GF.Infra.Ident as I
import qualified GF.Compile.GrammarToCanon as GC
import qualified GF.Canon.CanonToGrammar as CG
import qualified GF.Canon.MkGFC as MC
import qualified GF.Embed.EmbedAPI as EA
import GF.UseGrammar.Editing
import GF.System.SpeechInput (recognizeSpeech)
----import GrammarToXML
----import GrammarToMGrammar as M
import qualified Transfer.InterpreterAPI as T
import GF.System.Arch (myStdGen)
import GF.Text.UTF8
import GF.Data.Operations
import GF.Infra.UseIO
import GF.Data.Zipper
import Data.List (nub)
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Control.Monad (liftM)
import System (system)
import System.FilePath
type GFGrammar = StateGrammar
type GFCat = CFCat
type Ident = I.Ident
--- type Tree = V.Tree
-- these are enough for many simple applications
file2grammar :: FilePath -> IO GFGrammar
file2grammar file = do
egr <- appIOE $ optFile2grammar (iOpts [beSilent]) file
err (\s -> putStrLn s >> return emptyStateGrammar) return egr
linearize :: GFGrammar -> Tree -> String
linearize sgr = err id id . optLinearizeTree opts sgr where
opts = addOption firstLin $ stateOptions sgr
term2tree :: GFGrammar -> G.Term -> Tree
term2tree gr = errVal uTree . annotate (grammar gr) . qualifTerm (absId gr)
tree2term :: Tree -> G.Term
tree2term = tree2exp
linearizeToAll :: [GFGrammar] -> Tree -> [String]
linearizeToAll grs t = [linearize gr t | gr <- grs]
parse :: GFGrammar -> GFCat -> String -> [Tree]
parse sgr cat = errVal [] . parseString noOptions sgr cat
parseAny :: [GFGrammar] -> GFCat -> String -> [Tree]
parseAny grs cat s =
concat [errVal [] (parseString (options [iOpt "trynextlang"]) gr cat s) | gr <- grs]
translate :: GFGrammar -> GFGrammar -> GFCat -> String -> [String]
translate ig og cat = map (linearize og) . parse ig cat
translateToAll :: GFGrammar -> [GFGrammar] -> GFCat -> String -> [String]
translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat
translateFromAny :: [GFGrammar] -> GFGrammar -> GFCat -> String -> [String]
translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs]
translateBetweenAll :: [GFGrammar] -> GFCat -> String -> [String]
translateBetweenAll grs cat =
concat . map (linearizeToAll grs) . parseAny grs cat
homonyms :: GFGrammar -> GFCat -> Tree -> [Tree]
homonyms gr cat = nub . parse gr cat . linearize gr
hasAmbiguousLin :: GFGrammar -> GFCat -> Tree -> Bool
hasAmbiguousLin gr cat t = case (homonyms gr cat t) of
_:_:_ -> True
_ -> False
{- ----
-- returns printname if one exists; othewrise linearizes with metas
printOrLin :: GFGrammar -> Fun -> String
printOrLin gr = printOrLinearize (stateGrammarST gr)
-- reads a syntax file and writes it in a format wanted
transformGrammarFile :: Options -> FilePath -> IO String
transformGrammarFile opts file = do
sy <- useIOE GF.emptySyntax $ getSyntax opts file
return $ optPrintSyntax opts sy
-}
prIdent :: Ident -> String
prIdent = prt
string2GFCat :: String -> String -> GFCat
string2GFCat = string2CFCat
-- then stg for customizable and internal use
optFile2grammar :: Options -> FilePath -> IOE GFGrammar
optFile2grammar os f
| takeExtensions f == ".gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f
| otherwise = do
((_,_,gr,_),_) <- compileModule os emptyShellState f
ioeErr $ grammar2stateGrammar os gr
optFile2grammarE :: Options -> FilePath -> IOE GFGrammar
optFile2grammarE = optFile2grammar
string2treeInState :: GFGrammar -> String -> State -> Err Tree
string2treeInState gr s st = do
let metas = allMetas st
xs = map fst $ actBinds st
t0 <- pTerm s
let t = qualifTerm (absId gr) $ M.mkAbs xs $ refreshMetas metas $ t0
annotateExpInState (grammar gr) t st
string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term
string2srcTerm gr m s = do
t <- pTerm s
R.renameSourceTerm gr m t
randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree]
randomTreesIO opts gr n = do
gen <- myStdGen mx
t <- err (\s -> putS s >> return [])
(return . singleton) $
mkRandomTree gen mx g catfun
ts <- if n==1 then return [] else randomTreesIO opts gr (n-1)
return $ t ++ ts
where
catfun = case getOptVal opts withFun of
Just fun -> Right $ (absId gr, I.identC fun)
_ -> Left $ firstAbsCat opts gr
g = grammar gr
mx = optIntOrN opts flagDepth 41
putS s = if oElem beSilent opts then return () else putStrLnFlush s
generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree]
generateTrees opts gr mt =
optIntOrAll opts flagNumber
[tr | t <- Gen.generateTrees opts gr' cat dpt mn mt, Ok tr <- [mkTr t]]
where
mkTr = annotate gr' . qualifTerm (absId gr)
gr' = grammar gr
cat = firstAbsCat opts gr
dpt = maybe 3 id $ getOptInt opts flagDepth
mn = getOptInt opts flagAlts
speechGenerate :: Options -> String -> IO ()
speechGenerate opts str = do
let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage
system ("flite" +++ "\" " ++ str ++ "\"")
--- system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan)
return ()
speechInput :: Options -> StateGrammar -> IO [String]
speechInput opt s = recognizeSpeech name language cfg cat number
where
opts = addOptions opt (stateOptions s)
name = cncId s
cfg = stateCFG s -- FIXME: use lang flag to select grammar
language = fromMaybe "en_UK" (getOptVal opts speechLanguage)
cat = prCFCat (firstCatOpts opts s) ++ "{}.s"
number = optIntOrN opts flagNumber 1
optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String
optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr
optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String
optLinearizeTree opts0 gr t = case getOptVal opts transferFun of
Just m -> useByTransfer flin g (I.identC m) t
_ -> flin t
where
opts = addOptions opts0 (stateOptions gr)
flin = case getOptVal opts markLin of
Just mk
| mk == markOptXML -> lin markXML
| mk == markOptJava -> lin markXMLjgf
| mk == markOptStruct -> lin markBracket
| mk == markOptFocus -> lin markFocus
| mk == "metacat" -> lin metaCatMark
| otherwise -> lin noMark
_ -> lin noMark
lin mk
| oElem showRecord opts = liftM prt . linearizeNoMark g c
| oElem tableLin opts = liftM (unlines . map untok . prLinTable True) .
allLinTables True g c
| oElem showFields opts = liftM (unlines . map untok) .
allLinBranchFields g c
| oElem showAll opts = liftM (unlines . map untok . prLinTable False) .
allLinTables False g c
| otherwise = return . unlines . map untok . optIntOrOne . linTree2strings mk g c
g = grammar gr
c = cncId gr
untok = if False ---- oElem (markLin markOptXML) opts
then untokWithXML unt
else unt
unt = customOrDefault opts useUntokenizer customUntokenizer gr
optIntOrOne = take $ optIntOrN opts flagNumber 1
{- ----
untoksl . lin where
gr = concreteOf (stateGrammarST sgr)
lin -- options mutually exclusive, with priority: struct, rec, table, one
| oElem showStruct opts = markedLinString True gr . tree2loc
| oElem showRecord opts = err id prt . linTerm gr
| oElem tableLin opts = err id (concatMap prLinTable) . allLinsAsStrs gr
| oElem firstLin opts = unlines . map sstr . take 1 . allLinStrings gr
| otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr
untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr
opts' = addOptions opts $ stateOptions sgr
untoksl = unlines . map untoks . lines
-}
{-
optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String
optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where
gr = concreteOf (stateGrammarST sgr)
ts = annotateTrm sgr ts0
ms = map (renameTrm (lookupConcrete gr)) fs
lin -- options mutually exclusive, with priority: struct, rec, table
| oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms
| otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms
tkStrs = concat . map snd . concat . map snd
untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr
opts' = addOptions opts $ stateOptions sgr
untoksl = unlines . map untoks . lines
-}
optParseArg :: Options -> GFGrammar -> String -> [Tree]
optParseArg opts gr = err (const []) id . optParseArgErr opts gr
optParseArgAny :: Options -> [GFGrammar] -> String -> [Tree]
optParseArgAny opts grs s = concat [pars gr s | gr <- grs] where
pars gr = optParseArg opts gr --- grammar options!
optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree]
optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr
optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String)
optParseArgErrMsg opts gr s = do
let cat = firstCatOpts opts gr
g = grammar gr
(ts,m) <- parseStringMsg opts gr cat s
ts' <- case getOptVal opts transferFun of
Just m -> mkByTransfer (const $ return ts) g (I.identC m) s
_ -> return ts
return (ts',m)
-- | analyses word by word
morphoAnalyse :: Options -> GFGrammar -> String -> String
morphoAnalyse opts gr
| oElem (iOpt "status") opts = morphoTextStatus mo
| oElem beShort opts = morphoTextShort mo
| otherwise = morphoText mo
where
mo = morpho gr
isKnownWord :: GFGrammar -> String -> Bool
isKnownWord gr s = GF.UseGrammar.Morphology.isKnownWord (morpho gr) s
unknownTokens :: GFGrammar -> [CFTok] -> [String]
unknownTokens gr ts =
[w | TC w <- ts, unk w && unk (uncap w)] ++ [w | TS w <- ts, unk w]
where
unk w = not $ GF.API.isKnownWord gr w
uncap (c:cs) = toLower c : cs
uncap s = s
{-
prExpXML :: StateGrammar -> Term -> [String]
prExpXML gr = prElementX . term2elemx (stateAbstract gr)
prMultiGrammar :: Options -> ShellState -> String
prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts)
-}
-- access to customizable commands
optPrintGrammar :: Options -> StateGrammar -> String
optPrintGrammar opts = pg opts
where
pg = customOrDefault opts grammarPrinter customGrammarPrinter
optPrintMultiGrammar :: Options -> CanonGrammar -> String
optPrintMultiGrammar opts = encodeId . pmg opts . encode
where
pmg = customOrDefault opts grammarPrinter customMultiGrammarPrinter
-- if -utf8 was given, convert from language specific codings
encode = if oElem useUTF8 opts then mapModules moduleToUTF8 else id
-- if -utf8id was given, convert non-literals to UTF8
encodeId = if oElem useUTF8id opts then nonLiteralsToUTF8 else id
moduleToUTF8 m =
m{ jments = mapTree (onSnd (mapInfoTerms code)) (jments m),
flags = setFlag "coding" "utf8" (flags m) }
where code = onTokens (anyCodingToUTF8 (moduleOpts m))
moduleOpts = Opts . okError . mapM CG.redFlag . flags
optPrintSyntax :: Options -> GF.Grammar -> String
optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter
optPrintTree :: Options -> GFGrammar -> Tree -> String
optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter
-- | look for string command (-filter=x)
optStringCommand :: Options -> GFGrammar -> String -> String
optStringCommand opts g =
optIntOrAll opts flagLength .
customOrDefault opts filterString customStringCommand g
optTermCommand :: Options -> GFGrammar -> Tree -> [Tree]
optTermCommand opts st =
optIntOrAll opts flagNumber .
customOrDefault opts termCommand customTermCommand st
-- wraps term in a function and optionally computes the result
wrapByFun :: Options -> GFGrammar -> Ident -> Tree -> Tree
wrapByFun opts gr f t =
if oElem doCompute opts
then err (const t) id $ AC.computeAbsTerm (grammar gr) t' >>= annotate g
else err (const t) id $ annotate g t'
where
t' = qualifTerm (absId gr) $ M.appCons f [tree2exp t]
g = grammar gr
applyTransfer :: Options -> GFGrammar -> [(Ident,T.Env)] ->
(Maybe Ident,Ident) -> Tree -> Err [Tree]
applyTransfer opts gr trs (mm,f) t = mapM (annotate g) ts'
where
ts' = map (qualifTerm (absId gr)) $ trans tr f $ tree2exp t
g = grammar gr
tr = case mm of
Just m -> maybe empty id $ lookup m trs
_ -> ifNull empty (snd . head) trs
-- FIXME: if the returned value is a list,
-- return a list of trees
trans :: T.Env -> Ident -> Exp -> [Exp]
trans tr f = (:[]) . core2exp . T.evaluateExp tr . exp2core f
empty = T.builtin
{-
optTransfer :: Options -> StateGrammar -> G.Term -> G.Term
optTransfer opts g = case getOptVal opts transferFun of
Just f -> wrapByFun (addOption doCompute opts) g (M.zIdent f)
_ -> id
-}
optTokenizerResult :: Options -> GFGrammar -> String -> [[CFTok]]
optTokenizerResult opts gr = customOrDefault opts useTokenizer customTokenizer gr
optTokenizer :: Options -> GFGrammar -> String -> String
optTokenizer opts gr = show . optTokenizerResult opts gr
-- performs UTF8 if the language does not have flag coding=utf8; replaces name*U
-- | convert a Unicode string into a UTF8 encoded string
optEncodeUTF8 :: GFGrammar -> String -> String
optEncodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of
Just "utf8" -> id
_ -> encodeUTF8
-- | convert a UTF8 encoded string into a Unicode string
optDecodeUTF8 :: GFGrammar -> String -> String
optDecodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of
Just "utf8" -> decodeUTF8
_ -> id
-- | convert a string encoded with some coding given by the coding flag to UTF8
anyCodingToUTF8 :: Options -> String -> String
anyCodingToUTF8 opts =
encodeUTF8 . customOrDefault opts uniCoding customUniCoding
-- | Convert all text not inside double quotes to UTF8
nonLiteralsToUTF8 :: String -> String
nonLiteralsToUTF8 "" = ""
nonLiteralsToUTF8 ('"':cs) = '"' : l ++ nonLiteralsToUTF8 rs
where
(l,rs) = takeStringLit cs
-- | Split off an initial string ended by double quotes
takeStringLit :: String -> (String,String)
takeStringLit "" = ("","")
takeStringLit ('"':cs) = (['"'],cs)
takeStringLit ('\\':'"':cs) = ('\\':'"':xs,ys)
where (xs,ys) = takeStringLit cs
takeStringLit (c:cs) = (c:xs,ys)
where (xs,ys) = takeStringLit cs
nonLiteralsToUTF8 (c:cs) = encodeUTF8 [c] ++ nonLiteralsToUTF8 cs
printParadigm :: G.Term -> String
printParadigm term =
if hasTable term then
(unlines . map prBranch . branches . head . tables) term
else
prt term
where
tables t = case t of
G.R rs -> concatMap (tables . snd . snd) rs
G.T _ cs -> [cs]
_ -> []
hasTable t = not $ null $ tables t
branches cs = [(p:ps,s) |
(p,t) <- cs,
let ts = tables t,
(ps,s) <- if null ts then [([],t)]
else concatMap branches ts
]
prBranch (ps,s) = unwords (map prt ps ++ [prt s])

43
src-3.0/GF/API/BatchTranslate.hs
View File

@@ -1,43 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : BatchTranslate
-- Maintainer : Aarne Ranta
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:05 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- translate OCL, etc, files in batch mode
-----------------------------------------------------------------------------
module GF.API.BatchTranslate (translate) where
import GF.API
import GetMyTree (file2tree)
translate :: FilePath -> FilePath -> IO ()
translate fgr txt = do
gr <- file2grammar fgr
s <- file2tree txt
putStrLn $ linearize gr s
{- headers for model-specific grammars:
abstract userDefined = oclLibrary ** {
--# -path=.:abstract:prelude:English:ExtraEng
concrete userDefinedEng of userDefined = oclLibraryEng ** open externalOperEng in {
--# -path=.:abstract:prelude:German:ExtraGer
concrete userDefinedGer of userDefined = oclLibraryGer ** open
externalOperGer in {
It seems we should add open
ParadigmsX, ResourceExtX, PredicationX
-}

271
src-3.0/GF/API/GrammarToHaskell.hs
View File

@@ -1,271 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GrammarToHaskell
-- Maintainer : Aarne Ranta
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- to write a GF abstract grammar into a Haskell module with translations from
-- data objects into GF trees. Example: GSyntax for Agda.
-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
-----------------------------------------------------------------------------
module GF.API.GrammarToHaskell (grammar2haskell, grammar2haskellGADT) where
import qualified GF.Canon.GFC as GFC
import GF.Grammar.Macros
import GF.Infra.Modules
import GF.Data.Operations
import Data.List (isPrefixOf, find, intersperse)
import Data.Maybe (fromMaybe)
-- | the main function
grammar2haskell :: GFC.CanonGrammar -> String
grammar2haskell gr = foldr (++++) [] $
haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
where gr' = hSkeleton gr
grammar2haskellGADT :: GFC.CanonGrammar -> String
grammar2haskellGADT gr = foldr (++++) [] $
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++
haskPreamble ++ [datatypesGADT gr', composInstance gr', showInstanceGADT gr',
gfinstances gr', fginstances gr']
where gr' = hSkeleton gr
-- | by this you can prefix all identifiers with stg; the default is 'G'
gId :: OIdent -> OIdent
gId i = 'G':i
haskPreamble =
[
"module GSyntax where",
"",
"import GF.Infra.Ident",
"import GF.Grammar.Grammar",
"import GF.Grammar.PrGrammar",
"import GF.Grammar.Macros",
"import GF.Data.Compos",
"import GF.Data.Operations",
"",
"import Control.Applicative (pure,(<*>))",
"import Data.Traversable (traverse)",
"----------------------------------------------------",
"-- automatic translation from GF to Haskell",
"----------------------------------------------------",
"",
"class Gf a where gf :: a -> Trm",
"class Fg a where fg :: Trm -> a",
"",
predefInst "GString" "String" "K s",
"",
predefInst "GInt" "Integer" "EInt s",
"",
predefInst "GFloat" "Double" "EFloat s",
"",
"----------------------------------------------------",
"-- below this line machine-generated",
"----------------------------------------------------",
""
]
predefInst gtyp typ patt =
"newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
"instance Gf" +++ gtyp +++ "where" ++++
" gf (" ++ gtyp +++ "s) =" +++ patt +++++
"instance Fg" +++ gtyp +++ "where" ++++
" fg t =" ++++
" case termForm t of" ++++
" Ok ([]," +++ patt +++ ",[]) ->" +++ gtyp +++ "s" ++++
" _ -> error (\"no" +++ gtyp +++ "\" ++ prt t)"
type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String
datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g
fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g
hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype ("Cn",_) = "" ---
hDatatype (cat,[]) = ""
hDatatype (cat,rules) | isListCat (cat,rules) =
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+++ "deriving Show"
hDatatype (cat,rules) =
"data" +++ gId cat +++ "=" ++
(if length rules == 1 then "" else "\n ") +++
foldr1 (\x y -> x ++ "\n |" +++ y)
[gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++
" deriving Show"
-- GADT version of data types
datatypesGADT :: (String,HSkeleton) -> String
datatypesGADT (_,skel) =
unlines (concatMap hCatTypeGADT skel)
+++++
"data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel)
hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
hCatTypeGADT (cat,rules)
= ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
"data"+++gId cat++"_"]
hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
hDatatypeGADT (cat, rules)
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
| otherwise =
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
where t = "Tree" +++ gId cat ++ "_"
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance m (cat,[]) = ""
hInstance m (cat,rules)
| isListCat (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++++
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
" gf (" ++ gId cat +++ "(x:xs)) = "
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
-- no show for GADTs
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
| otherwise =
"instance Gf" +++ gId cat +++ "where" ++
(if length rules == 1 then "" else "\n") +++
foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules]
where
ec = elemCat cat
baseVars = mkVars (baseSize (cat,rules))
mkInst f xx = let xx' = mkVars (length xx) in "gf " ++
(if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
"=" +++ mkRHS f xx'
mkVars n = ["x" ++ show i | i <- [1..n]]
mkRHS f vars = "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
----fInstance m ("Cn",_) = "" ---
fInstance m (cat,[]) = ""
fInstance m (cat,rules) =
"instance Fg" +++ gId cat +++ "where" ++++
" fg t =" ++++
" case termForm t of" ++++
foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++
" _ -> error (\"no" +++ cat ++ " \" ++ prt t)"
where
mkInst f xx =
" Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++
"[" ++ prTList "," xx' ++ "])" +++
"->" +++ mkRHS f xx'
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
mkRHS f vars
| isListCat (cat,rules) =
if "Base" `isPrefixOf` f then
gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
else
let (i,t) = (init vars,last vars)
in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++
gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"]))
| otherwise =
gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars]
composInstance :: (String,HSkeleton) -> String
composInstance (_,skel) = unlines $
["instance Compos Tree where",
" compos f t = case t of"]
++ map (" "++) (concatMap prComposCat skel
++ if not allRecursive then ["_ -> pure t"] else [])
where
prComposCat c@(cat, fs)
| isListCat c = [gId cat +++ "xs" +++ "->"
+++ "pure" +++ gId cat +++ "<*> traverse f" +++ "xs"]
| otherwise = concatMap (prComposFun cat) fs
prComposFun :: OIdent -> (OIdent,[OIdent]) -> [String]
prComposFun cat c@(fun,args)
| any isTreeType args = [gId fun +++ unwords vars +++ "->" +++ rhs]
| otherwise = []
where vars = ["x" ++ show n | n <- [1..length args]]
rhs = "pure" +++ gId fun +++ unwords (zipWith prRec vars args)
where prRec var typ
| not (isTreeType typ) = "<*>" +++ "pure" +++ var
| otherwise = "<*>" +++ "f" +++ var
allRecursive = and [any isTreeType args | (_,fs) <- skel, (_,args) <- fs]
isTreeType cat = cat `elem` (map fst skel ++ builtin)
isList cat = case filter ((==cat) . fst) skel of
[] -> error $ "Unknown cat " ++ show cat
x:_ -> isListCat x
builtin = ["GString", "GInt", "GFloat"]
showInstanceGADT :: (String,HSkeleton) -> String
showInstanceGADT (_,skel) = unlines $
["instance Show (Tree c) where",
" showsPrec n t = case t of"]
++ map (" "++) (concatMap prShowCat skel)
++ [" where opar n = if n > 0 then showChar '(' else id",
" cpar n = if n > 0 then showChar ')' else id"]
where
prShowCat c@(cat, fs)
| isListCat c = [gId cat +++ "xs" +++ "->" +++ "showList" +++ "xs"]
| otherwise = map (prShowFun cat) fs
prShowFun :: OIdent -> (OIdent,[OIdent]) -> String
prShowFun cat (fun,args)
| null vars = gId fun +++ "->" +++ "showString" +++ show fun
| otherwise = gId fun +++ unwords vars +++ "->"
+++ "opar n . showString" +++ show fun
+++ unwords [". showChar ' ' . showsPrec 1 " ++ x | x <- vars]
+++ ". cpar n"
where vars = ["x" ++ show n | n <- [1..length args]]
hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton)
hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
collectR rr hh =
case rr of
(fun,typ):rs -> case catSkeleton typ of
Ok (cats,cat) ->
collectR rs (updateSkeleton (symid (snd cat)) hh (fun,
map (symid . snd) cats))
_ -> collectR rs hh
_ -> hh
cats = [symid cat | (cat,GFC.AbsCat _ _) <- defs]
rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule =
case skel of
(cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
(cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule
_ -> error $ cat ++ ": updating empty skeleton with" +++ show rule
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where c = elemCat cat
fs = map fst rules
-- | Gets the element category of a list category.
elemCat :: OIdent -> OIdent
elemCat = drop 4
isBaseFun :: OIdent -> Bool
isBaseFun f = "Base" `isPrefixOf` f
isConsFun :: OIdent -> Bool
isConsFun f = "Cons" `isPrefixOf` f
baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
baseSize (_,rules) = length bs
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules

94
src-3.0/GF/API/GrammarToTransfer.hs
View File

@@ -1,94 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GrammarToTransfer
-- Maintainer : Björn Bringert
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- Creates a data type definition in the transfer language
-- for an abstract module.
-----------------------------------------------------------------------------
module GF.API.GrammarToTransfer (grammar2transfer) where
import qualified GF.Canon.GFC as GFC
import qualified GF.Grammar.Abstract as A
import GF.Grammar.Macros
import GF.Infra.Modules
import GF.Data.Operations
import Transfer.Syntax.Abs as S
import Transfer.Syntax.Print
-- | the main function
grammar2transfer :: GFC.CanonGrammar -> String
grammar2transfer gr = printTree $ S.Module imports decls
where
cat = S.Ident "Cat" -- FIXME
tree = S.Ident "Tree" -- FIXME
defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
-- get category name and context
cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs]
-- get function name and type
funs = [(fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
imports = [Import (S.Ident "prelude")]
decls = [cats2cat cat tree cats, funs2tree cat tree funs] ++ instances tree
-- | Create a declaration of the type of categories given a list
-- of category names and their contexts.
cats2cat :: S.Ident -- ^ the name of the Cat type
-> S.Ident -- ^ the name of the Tree type
-> [(A.Ident,A.Context)] -> Decl
cats2cat cat tree = S.DataDecl cat S.EType . map (uncurry catCons)
where
catCons i c = S.ConsDecl (id2id i) (catConsType c)
catConsType = foldr pi (S.EVar cat)
pi (i,x) t = mkPi (id2pv i) (addTree tree $ term2exp x) t
funs2tree :: S.Ident -- ^ the name of the Cat type
-> S.Ident -- ^ the name of the Tree type
-> [(A.Ident,A.Type)] -> Decl
funs2tree cat tree =
S.DataDecl tree (S.EPiNoVar (S.EVar cat) S.EType) . map (uncurry funCons)
where
funCons i t = S.ConsDecl (id2id i) (addTree tree $ term2exp t)
term2exp :: A.Term -> S.Exp
term2exp t = case t of
A.Vr i -> S.EVar (id2id i)
A.App t1 t2 -> S.EApp (term2exp t1) (term2exp t2)
A.Abs i t1 -> S.EAbs (id2pv i) (term2exp t1)
A.Prod i t1 t2 -> mkPi (id2pv i) (term2exp t1) (term2exp t2)
A.Q m i -> S.EVar (id2id i)
_ -> error $ "term2exp: can't handle " ++ show t
mkPi :: S.VarOrWild -> S.Exp -> S.Exp -> S.Exp
mkPi VWild t e = S.EPiNoVar t e
mkPi v t e = S.EPi v t e
id2id :: A.Ident -> S.Ident
id2id = S.Ident . symid
id2pv :: A.Ident -> S.VarOrWild
id2pv i = case symid i of
"h_" -> S.VWild -- FIXME: hacky?
x -> S.VVar (S.Ident x)
-- FIXME: I think this is not general enoguh.
addTree :: S.Ident -> S.Exp -> S.Exp
addTree tree x = case x of
S.EPi i t e -> S.EPi i (addTree tree t) (addTree tree e)
S.EPiNoVar t e -> S.EPiNoVar (addTree tree t) (addTree tree e)
e -> S.EApp (S.EVar tree) e
instances :: S.Ident -> [S.Decl]
instances tree = [DeriveDecl (S.Ident "Eq") tree,
DeriveDecl (S.Ident "Compos") tree]

96
src-3.0/GF/API/IOGrammar.hs
View File

@@ -1,96 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : IOGrammar
-- Maintainer : Aarne Ranta
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:40 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.20 $
--
-- for reading grammars and terms from strings and files
-----------------------------------------------------------------------------
module GF.API.IOGrammar (shellStateFromFiles,
getShellStateFromFiles) where
import GF.Grammar.Abstract
import qualified GF.Canon.GFC as GFC
import GF.Compile.PGrammar
import GF.Grammar.TypeCheck
import GF.Compile.Compile
import GF.Compile.ShellState
import GF.Compile.NoParse
import GF.Probabilistic.Probabilistic
import GF.UseGrammar.Treebank
import GF.Infra.Modules
import GF.Infra.ReadFiles (isOldFile)
import GF.Infra.Option
import GF.Data.Operations
import GF.Infra.UseIO
import GF.System.Arch
import qualified Transfer.InterpreterAPI as T
import Control.Monad (liftM)
import System.FilePath
-- | a heuristic way of renaming constants is used
string2absTerm :: String -> String -> Term
string2absTerm m = renameTermIn m . pTrm
renameTermIn :: String -> Term -> Term
renameTermIn m = refreshMetas [] . rename [] where
rename vs t = case t of
Abs x b -> Abs x (rename (x:vs) b)
Vr c -> if elem c vs then t else Q (zIdent m) c
App f a -> App (rename vs f) (rename vs a)
_ -> t
string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree
string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt
----string2paramList :: ConcreteST -> String -> [Term]
---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList
shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
shellStateFromFiles opts st file = do
ign <- ioeIO $ getNoparseFromFile opts file
let top = identC $ justModuleName file
sh <- case takeExtensions file of
".trc" -> do
env <- ioeIO $ T.loadFile file
return $ addTransfer (top,env) st
".gfcm" -> do
cenv <- compileOne opts (compileEnvShSt st []) file
ioeErr $ updateShellState opts ign Nothing st cenv
s | elem s [".cf",".ebnf"] -> do
let osb = addOptions (options []) opts
grts <- compileModule osb st file
ioeErr $ updateShellState opts ign Nothing st grts
s | oElem (iOpt "treebank") opts -> do
tbs <- ioeIO $ readUniTreebanks file
return $ addTreebanks tbs st
_ -> do
b <- ioeIO $ isOldFile file
let opts' = if b then (addOption showOld opts) else opts
let osb = if oElem showOld opts'
then addOptions (options []) opts' -- for old no emit
else addOptions (options [emitCode]) opts'
grts <- compileModule osb st file
let mtop = if oElem showOld opts' then Nothing else Just top
ioeErr $ updateShellState opts' ign mtop st grts
if (isSetFlag opts probFile || oElem (iOpt "prob") opts)
then do
probs <- ioeIO $ getProbsFromFile opts file
let lang = maybe top id $ concrete sh --- to work with cf, too
ioeErr $ addProbs (lang,probs) sh
else return sh
getShellStateFromFiles :: Options -> FilePath -> IO ShellState
getShellStateFromFiles os =
useIOE emptyShellState .
shellStateFromFiles os emptyShellState

25
src-3.0/GF/API/MyParser.hs
View File

@@ -1,25 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MyParser
-- Maintainer : Peter Ljunglöf
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- template to define your own parser (obsolete?)
-----------------------------------------------------------------------------
module GF.API.MyParser (myParser) where
import GF.Compile.ShellState
import GF.CF.CFIdent
import GF.CF.CF
import GF.Data.Operations
-- type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String)
myParser :: StateGrammar -> CFCat -> CFParser
myParser gr cat toks = ([],"Would you like to add your own parser?")

213
src-3.0/GF/CF/CF.hs
View File

@@ -1,213 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- context-free grammars. AR 15\/12\/1999 -- 30\/3\/2000 -- 2\/6\/2001 -- 3\/12\/2001
-----------------------------------------------------------------------------
module GF.CF.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 GF.Data.Operations
import GF.Data.Str
import GF.Canon.AbsGFC
import GF.Canon.GFC
import GF.CF.CFIdent
import Data.List (nub,nubBy)
import Data.Char (isUpper, isLower, toUpper, toLower)
-- CF grammar data types
-- | abstract type CF.
-- Invariant: each category has all its rules grouped with it
-- also: the list is never empty (the category is just missing then)
newtype CF = CF ([CFRuleGroup], CFPredef)
type CFRule = (CFFun, (CFCat, [CFItem]))
type CFRuleGroup = (CFCat,[CFRule])
-- | CFPredef is a hack for variable symbols and literals; normally = @const []@
data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show)
newtype CFTree = CFTree (CFFun,(CFCat, [CFTree])) deriving (Eq, Show)
-- | recognize literals, variables, etc
type CFPredef = CFTok -> [(CFCat, CFFun)]
-- | Wadler style + return information
type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String)
cfParseResults :: ([(CFTree,[CFTok])],String) -> [CFTree]
cfParseResults rs = [b | (b,[]) <- fst rs]
-- | terminals are regular expressions on words; to be completed to full regexp
data RegExp =
RegAlts [CFWord] -- ^ list of alternative words
| RegSpec CFTok -- ^ special token
deriving (Eq, Ord, Show)
type CFWord = String
-- the above types should be kept abstract, and the following functions used
-- to construct CF grammars
emptyCF :: CF
emptyCF = CF ([], emptyCFPredef)
emptyCFPredef :: CFPredef
emptyCFPredef = const []
rules2CF :: [CFRule] -> CF
rules2CF rs = CF (groupCFRules rs, emptyCFPredef)
groupCFRules :: [CFRule] -> [(CFCat,[CFRule])]
groupCFRules = foldr ins [] where
ins rule crs = case crs of
(c,r) : rs | compatCF c cat -> (c,rule:r) : rs
cr : rs -> cr : ins rule rs
_ -> [(cat,[rule])]
where
cat = valCatCF rule
-- to construct rules
-- | make a rule from a single token without constituents
atomCFRule :: CFCat -> CFFun -> CFTok -> CFRule
atomCFRule c f s = (f, (c, [atomCFTerm s]))
-- | usual terminal
atomCFTerm :: CFTok -> CFItem
atomCFTerm = CFTerm . atomRegExp
atomRegExp :: CFTok -> RegExp
atomRegExp t = case t of
TS s -> RegAlts [s]
_ -> RegSpec t
-- | terminal consisting of alternatives
altsCFTerm :: [String] -> CFItem
altsCFTerm = CFTerm . RegAlts
-- to construct trees
-- | make a tree without constituents
atomCFTree :: CFCat -> CFFun -> CFTree
atomCFTree c f = buildCFTree c f []
-- | make a tree with constituents.
buildCFTree :: CFCat -> CFFun -> [CFTree] -> CFTree
buildCFTree c f trees = CFTree (f,(c,trees))
{- ----
cfMeta0 :: CFTree
cfMeta0 = atomCFTree uCFCat metaCFFun
-- used in happy
litCFTree :: String -> CFTree --- Maybe CFTree
litCFTree s = maybe cfMeta0 id $ do
(c,f) <- getCFLiteral s
return $ buildCFTree c f []
-}
-- to decide whether a token matches a terminal item
matchCFTerm :: CFItem -> CFTok -> Bool
matchCFTerm (CFTerm t) s = satRegExp t s
matchCFTerm _ _ = False
satRegExp :: RegExp -> CFTok -> Bool
satRegExp r t = case (r,t) of
(RegAlts tt, TS s) -> elem s tt
(RegAlts tt, TC s) -> or [elem s' tt | s' <- caseUpperOrLower s]
(RegSpec x, _) -> t == x ---
_ -> False
where
caseUpperOrLower s = case s of
c:cs | isUpper c -> [s, toLower c : cs]
c:cs | isLower c -> [s, toUpper c : cs]
_ -> [s]
-- to analyse a CF grammar
catsOfCF :: CF -> [CFCat]
catsOfCF (CF (rr,_)) = map fst rr
rulesOfCF :: CF -> [CFRule]
rulesOfCF (CF (rr,_)) = concatMap snd rr
ruleGroupsOfCF :: CF -> [(CFCat,[CFRule])]
ruleGroupsOfCF (CF (rr,_)) = rr
rulesForCFCat :: CF -> CFCat -> [CFRule]
rulesForCFCat (CF (rr,_)) cat = maybe [] id $ lookup cat rr
valCatCF :: CFRule -> CFCat
valCatCF (_,(c,_)) = c
valItemsCF :: CFRule -> [CFItem]
valItemsCF (_,(_,i)) = i
valFunCF :: CFRule -> CFFun
valFunCF (f,(_,_)) = f
startCat :: CF -> CFCat
startCat (CF (rr,_)) = fst (head rr) --- hardly useful
predefOfCF :: CF -> CFPredef
predefOfCF (CF (_,f)) = f
appCFPredef :: CF -> CFTok -> [(CFCat, CFFun)]
appCFPredef = ($) . predefOfCF
valCFItem :: CFItem -> Either RegExp CFCat
valCFItem (CFTerm r) = Left r
valCFItem (CFNonterm nt) = Right nt
cfTokens :: CF -> [CFWord]
cfTokens cf = nub $ concat $ [ wordsOfRegExp i | r <- rulesOfCF cf,
CFTerm i <- valItemsCF r]
wordsOfRegExp :: RegExp -> [CFWord]
wordsOfRegExp (RegAlts tt) = tt
wordsOfRegExp _ = []
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
-- | coercion to the older predef cf type
predefRules :: CFPredef -> CFTok -> [CFRule]
predefRules pre s = [atomCFRule c f s | (c,f) <- pre s]

253
src-3.0/GF/CF/CFIdent.hs
View File

@@ -1,253 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CFIdent
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:40 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- symbols (categories, functions) for context-free grammars.
-----------------------------------------------------------------------------
module GF.CF.CFIdent (-- * Tokens and categories
CFTok(..), CFCat(..),
tS, tC, tL, tI, tF, tV, tM, tInt,
prCFTok,
-- * Function names and profiles
CFFun(..), Profile,
wordsCFTok,
-- * CF Functions
mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun,
intCFFun, floatCFFun, dummyCFFun,
cfFun2String, cfFun2Ident, cfFun2Profile, metaCFFun,
-- * CF Categories
mkCIdent, ident2CFCat, labels2CFCat, string2CFCat,
catVarCF, cat2CFCat, cfCatString, cfCatInt,cfCatFloat,
moduleOfCFCat, cfCat2Cat, cfCat2Ident, lexCFCat,
-- * CF Tokens
string2CFTok, str2cftoks,
-- * Comparisons
compatToks, compatTok, compatCFFun, compatCF,
wordsLits
) where
import GF.Data.Operations
import GF.Canon.GFC
import GF.Infra.Ident
import GF.Grammar.Values (cPredefAbs)
import GF.Canon.AbsGFC
import GF.Grammar.Macros (ident2label)
import GF.Grammar.PrGrammar
import GF.Data.Str
import Data.Char (toLower, toUpper, isSpace)
import Data.List (intersperse)
-- | this type should be abstract
data CFTok =
TS String -- ^ normal strings
| TC String -- ^ strings that are ambiguous between upper or lower case
| TL String -- ^ string literals
| TI Integer -- ^ integer literals
| TF Double -- ^ float literals
| TV Ident -- ^ variables
| TM Int String -- ^ metavariables; the integer identifies it
deriving (Eq, Ord, Show)
-- | this type should be abstract
newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show)
tS :: String -> CFTok
tC :: String -> CFTok
tL :: String -> CFTok
tI :: String -> CFTok
tF :: String -> CFTok
tV :: String -> CFTok
tM :: String -> CFTok
tS = TS
tC = TC
tL = TL
tI = TI . read
tF = TF . read
tV = TV . identC
tM = TM 0
tInt :: Integer -> CFTok
tInt = TI
prCFTok :: CFTok -> String
prCFTok t = case t of
TS s -> s
TC s -> s
TL s -> s
TI i -> show i
TF i -> show i
TV x -> prt x
TM i m -> m --- "?" --- m
-- | to build trees: the Atom contains a GF function, @Cn | Meta | Vr | Literal@
newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Ord,Show)
-- - - - - - - - - - - - - - - - - - - - - ^^^ added by peb, 21/5-04
type Profile = [([[Int]],[Int])]
wordsCFTok :: CFTok -> [String]
wordsCFTok t = case t of
TC (c:cs) -> [c':cs | c' <- [toUpper c, toLower c]]
_ -> [prCFTok t]
-- the following functions should be used instead of constructors
-- to construct CF functions
mkCFFun :: Atom -> CFFun
mkCFFun t = CFFun (t,[])
varCFFun :: Ident -> CFFun
varCFFun = mkCFFun . AV
consCFFun :: CIdent -> CFFun
consCFFun = mkCFFun . AC
-- | standard way of making cf fun
string2CFFun :: String -> String -> CFFun
string2CFFun m c = consCFFun $ mkCIdent m c
stringCFFun :: String -> CFFun
stringCFFun = mkCFFun . AS
intCFFun :: Integer -> CFFun
intCFFun = mkCFFun . AI
floatCFFun :: Double -> CFFun
floatCFFun = mkCFFun . AF
-- | used in lexer-by-need rules
dummyCFFun :: CFFun
dummyCFFun = varCFFun $ identC "_"
cfFun2String :: CFFun -> String
cfFun2String (CFFun (f,_)) = prt f
cfFun2Ident :: CFFun -> Ident
cfFun2Ident (CFFun (f,_)) = identC $ prt_ f ---
cfFun2Profile :: CFFun -> Profile
cfFun2Profile (CFFun (_,p)) = p
{- ----
strPro2cfFun :: String -> Profile -> CFFun
strPro2cfFun str p = (CFFun (AC (Ident str), p))
-}
metaCFFun :: CFFun
metaCFFun = mkCFFun $ AM 0
-- to construct CF categories
-- | belongs elsewhere
mkCIdent :: String -> String -> CIdent
mkCIdent m c = CIQ (identC m) (identC c)
ident2CFCat :: CIdent -> Ident -> CFCat
ident2CFCat mc d = CFCat (mc, L d)
labels2CFCat :: CIdent -> [Label] -> CFCat
labels2CFCat mc d = CFCat (mc, L (identC (concat (intersperse "." (map prt d))))) ----
-- | standard way of making cf cat: label s
string2CFCat :: String -> String -> CFCat
string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s")
idents2CFCat :: Ident -> Ident -> CFCat
idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s")
catVarCF :: CFCat
catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ----
cat2CFCat :: (Ident,Ident) -> CFCat
cat2CFCat = uncurry idents2CFCat
-- | literals
cfCatString :: CFCat
cfCatString = string2CFCat (prt cPredefAbs) "String"
cfCatInt, cfCatFloat :: CFCat
cfCatInt = string2CFCat (prt cPredefAbs) "Int"
cfCatFloat = string2CFCat (prt cPredefAbs) "Float"
{- ----
uCFCat :: CFCat
uCFCat = cat2CFCat uCat
-}
moduleOfCFCat :: CFCat -> Ident
moduleOfCFCat (CFCat (CIQ m _, _)) = m
-- | the opposite direction
cfCat2Cat :: CFCat -> (Ident,Ident)
cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
cfCat2Ident :: CFCat -> Ident
cfCat2Ident = snd . cfCat2Cat
lexCFCat :: CFCat -> CFCat
lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*")
-- to construct CF tokens
string2CFTok :: String -> CFTok
string2CFTok = tS
str2cftoks :: Str -> [CFTok]
str2cftoks = map tS . wordsLits . sstr
-- decide if two token lists look the same (in parser postprocessing)
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
alts u = case u of
TC (c:s) -> [toLower c : s, toUpper c : s]
TL s -> [s, prQuotedString s]
_ -> [prCFTok u]
-- | decide if two CFFuns have the same function head (profiles may differ)
compatCFFun :: CFFun -> CFFun -> Bool
compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g
-- | decide whether two categories match
-- the modifiers can be from different modules, but on the same extension
-- path, so there is no clash, and they can be safely ignored ---
compatCF :: CFCat -> CFCat -> Bool
----compatCF = (==)
compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l'
-- | Like 'words', but does not split on whitespace inside
-- double quotes.wordsLits :: String -> [String]
-- Also treats escaped quotes in quotes (AR 21/12/2005) by breaks
-- instead of break
wordsLits [] = []
wordsLits (c:cs) | isSpace c = wordsLits (dropWhile isSpace cs)
| isQuote c
= let (l,rs) = breaks (==c) cs
rs' = drop 1 rs
in ([c]++l++[c]):wordsLits rs'
| otherwise = let (w,rs) = break isSpaceQ cs
in (c:w):wordsLits rs
where
breaks c cs = case break c cs of
(l@(_:_),d:rs) | last l == '\\' ->
let (r,ts) = breaks c rs in (l++[d]++r, ts)
v -> v
isQuote c = elem c "\"'"
isSpaceQ c = isSpace c ---- || isQuote c

62
src-3.0/GF/CF/CFtoGrammar.hs
View File

@@ -1,62 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CFtoGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:09 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- 26\/1\/2000 -- 18\/4 -- 24\/3\/2004
-----------------------------------------------------------------------------
module GF.CF.CFtoGrammar (cf2grammar) where
import GF.Infra.Ident
import GF.Grammar.Grammar
import qualified GF.Source.AbsGF as A
import qualified GF.Source.GrammarToSource as S
import GF.Grammar.Macros
import GF.CF.CF
import GF.CF.CFIdent
import GF.CF.PPrCF
import GF.Data.Operations
import Data.List (nub)
import Data.Char (isSpace)
cf2grammar :: CF -> [A.TopDef]
cf2grammar cf = concatMap S.trAnyDef (abs ++ conc) where
rules = rulesOfCF cf
abs = cats ++ funs
conc = lintypes ++ lins
cats = [(cat, AbsCat (yes []) (yes [])) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat
lintypes = [(cat, CncCat (yes defLinType) nope nope) | (cat,AbsCat _ _) <- cats]
(funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident]
cf2cat (_,(cat, items)) = map cfCat2Ident $ cat : [c | CFNonterm c <- items]
cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
cf2rule (fun, (cat, items)) = (def,ldef) where
f = cfFun2Ident fun
def = (f, AbsFun (yes (mkProd (args', Cn (cfCat2Ident cat), []))) nope)
args0 = zip (map (identV "x") [0..]) items
args = [(v, Cn (cfCat2Ident c)) | (v, CFNonterm c) <- args0]
args' = [(zIdent "_", Cn (cfCat2Ident c)) | (_, CFNonterm c) <- args0]
ldef = (f, CncFun
Nothing
(yes (mkAbs (map fst args)
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
nope)
mkIt (v, CFNonterm _) = P (Vr v) theLinLabel
mkIt (_, CFTerm (RegAlts [a])) = K a
mkIt _ = K "" --- regexp not recognized in input CF ; use EBNF for this
foldconcat [] = K ""
foldconcat tt = foldr1 C tt

214
src-3.0/GF/CF/CanonToCF.hs
View File

@@ -1,214 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CanonToCF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:41 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.15 $
--
-- AR 27\/1\/2000 -- 3\/12\/2001 -- 8\/6\/2003
-----------------------------------------------------------------------------
module GF.CF.CanonToCF (canon2cf) where
import GF.System.Tracing -- peb 8/6-04
import GF.Data.Operations
import GF.Infra.Option
import GF.Infra.Ident
import GF.Canon.AbsGFC
import GF.Grammar.LookAbs (allBindCatsOf)
import GF.Canon.GFC
import GF.Grammar.Values (isPredefCat,cPredefAbs)
import GF.Grammar.PrGrammar
import GF.Canon.CMacros
import qualified GF.Infra.Modules as M
import GF.CF.CF
import GF.CF.CFIdent
import GF.UseGrammar.Morphology
import GF.Data.Trie2
import Data.List (nub,partition)
import Control.Monad
-- | The main function: for a given cnc module 'm', build the CF grammar with all the
-- rules coming from modules that 'm' extends. The categories are qualified by
-- the abstract module name 'a' that 'm' is of.
-- The ign argument tells what rules not to generate a parser for.
canon2cf :: Options -> (Ident -> Bool) -> CanonGrammar -> Ident -> Err CF
canon2cf opts ign gr c = tracePrt "#size of CF" (err id (show.length.rulesOfCF)) $ do -- peb 8/6-04
let ms = M.allExtends gr c
a <- M.abstractOfConcrete gr c
let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms]
let mms = [(a, tree2list (M.jments m)) | m <- cncs]
cnc <- liftM M.jments $ M.lookupModMod gr c
rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts ign cnc)) mms
let bindcats = map snd $ allBindCatsOf gr
let rules = filter (not . isCircularCF) rules0 ---- temporarily here
let grules = groupCFRules rules
let predef = mkCFPredef opts bindcats grules
return $ CF predef
cnc2cfCond :: Options -> (Ident -> Bool) -> BinTree Ident Info ->
Ident -> [(Ident,Info)] -> Err [CFRule]
cnc2cfCond opts ign cnc m gr =
liftM concat $
mapM lin2cf [(m,fun,cat,args,lin) |
(fun, CncFun cat args lin _) <- gr, notign fun, is fun]
where
is f = isInBinTree f cnc
notign = not . ign
type IFun = Ident
type ICat = CIdent
-- | all CF rules corresponding to a linearization rule
lin2cf :: (Ident, IFun, ICat, [ArgVar], Term) -> Err [CFRule]
lin2cf (m,fun,cat,args,lin) = errIn ("building CF rule for" +++ prt fun) $ do
let rhss0 = allLinBranches lin -- :: [([Label], Term)]
rhss1 <- mapM (mkCFItems m) rhss0 -- :: [([Label], [[PreCFItem]])]
mapM (mkCfRules m fun cat args) rhss1 >>= return . nub . concat
-- | making sequences of CF items from every branch in a linearization
mkCFItems :: Ident -> ([Label], Term) -> Err ([Label], [[PreCFItem]])
mkCFItems m (labs,t) = do
items <- term2CFItems m t
return (labs, items)
-- | making CF rules from sequences of CF items
mkCfRules :: Ident -> IFun -> ICat -> [ArgVar] -> ([Label], [[PreCFItem]]) -> Err [CFRule]
mkCfRules m fun cat args (lab, itss) = mapM mkOneRule itss
where
mkOneRule its = do
let nonterms = zip [0..] [(pos,d,v) | PNonterm _ pos d v <- its]
profile = mkProfile nonterms
cfcat = labels2CFCat (redirectIdent m cat) lab
cffun = CFFun (AC (CIQ m fun), profile)
cfits = map precf2cf its
return (cffun,(cfcat,cfits))
mkProfile nonterms = map mkOne args
where
mkOne (A c i) = mkOne (AB c 0 i)
mkOne (AB _ b i) = (map mkB [0..b-1], [k | (k,(j,_,True)) <- nonterms, j==i])
where
mkB x = [k | (k,(j, [LV y], False)) <- nonterms, j == i, y == x]
-- | intermediate data structure of CFItems with information for profiles
data PreCFItem =
PTerm RegExp -- ^ like ordinary Terminal
| PNonterm CIdent Integer [Label] Bool -- ^ cat, position, part\/bind, whether arg
deriving Eq
precf2cf :: PreCFItem -> CFItem
precf2cf (PTerm r) = CFTerm r
precf2cf (PNonterm cm _ ls True) = CFNonterm (labels2CFCat cm ls)
precf2cf (PNonterm _ _ _ False) = CFNonterm catVarCF
-- | the main job in translating linearization rules into sequences of cf items
term2CFItems :: Ident -> Term -> Err [[PreCFItem]]
term2CFItems m t = errIn "forming cf items" $ case t of
S c _ -> t2c c
T _ cc -> do
its <- mapM t2c [t | Cas _ t <- cc]
tryMkCFTerm (concat its)
V _ cc -> do
its <- mapM t2c [t | t <- cc]
tryMkCFTerm (concat its)
C t1 t2 -> do
its1 <- t2c t1
its2 <- t2c t2
return [x ++ y | x <- its1, y <- its2]
FV ts -> do
its <- mapM t2c ts
tryMkCFTerm (concat its)
P (S c _) _ -> t2c c --- w-around for bug in Compute? AR 31/1/2006
P arg s -> extrR arg s
K (KS s) -> return [[PTerm (RegAlts [s]) | not (null s)]]
E -> return [[]]
K (KP d vs) -> do
let its = [PTerm (RegAlts [s]) | s <- d]
let itss = [[PTerm (RegAlts [s]) | s <- t] | Var t _ <- vs]
tryMkCFTerm (its : itss)
_ -> return [] ---- prtBad "no cf for" t ----
where
t2c = term2CFItems m
-- optimize the number of rules by a factorization
tryMkCFTerm :: [[PreCFItem]] -> Err [[PreCFItem]]
tryMkCFTerm ii@(its:itss) | all (\x -> length x == length its) itss =
case mapM mkOne (counterparts ii) of
Ok tt -> return [tt]
_ -> return ii
where
mkOne cfits = case mapM mkOneTerm cfits of
Ok tt -> return $ PTerm (RegAlts (concat (nub tt)))
_ -> mkOneNonTerm cfits
mkOneTerm (PTerm (RegAlts t)) = return t
mkOneTerm _ = Bad ""
mkOneNonTerm (n@(PNonterm _ _ _ _) : cc) =
if all (== n) cc
then return n
else Bad ""
mkOneNonTerm _ = Bad ""
counterparts ll = [map (!! i) ll | i <- [0..length (head ll) - 1]]
tryMkCFTerm itss = return itss
extrR arg lab = case (arg0,labs) of
(Arg (A cat pos), [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]]
(Arg (AB cat b pos), [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]]
(Arg (A cat pos), _) -> return [[PNonterm (cIQ cat) pos labs True]]
(Arg (AB cat b pos), _) -> return [[PNonterm (cIQ cat) pos labs True]]
---- ??
_ -> prtBad "cannot extract record field from" arg
where
(arg0,labs) = headProj arg [lab]
headProj r ls = case r of
P r0 l0 -> headProj r0 (l0:ls)
S r0 _ -> headProj r0 ls
_ -> (r,ls)
cIQ c = if isPredefCat c then CIQ cPredefAbs c else CIQ m c
mkCFPredef :: Options -> [Ident] -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef)
mkCFPredef opts binds rules = (ruls, \s -> preds0 s ++ look s) where
(ruls,preds) = if oElem lexerByNeed opts -- option -cflexer
then predefLexer rules
else (rules,emptyTrie)
preds0 s =
[(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++
[(cat, varCFFun x) | TV x <- [s], cat <- catVarCF : bindcats] ++
[(cfCatString, stringCFFun t) | TL t <- [s]] ++
[(cfCatInt, intCFFun t) | TI t <- [s]] ++
[(cfCatFloat, floatCFFun t) | TF t <- [s]]
cats = nub [c | (_,rs) <- rules, (_,(_,its)) <- rs, CFNonterm c <- its]
bindcats = [c | c <- cats, elem (cfCat2Ident c) binds]
look = concatMap snd . map (trieLookup preds) . wordsCFTok --- for TC tokens
--- TODO: integrate with morphology
--- predefLexer :: [CFRuleGroup] -> ([CFRuleGroup],BinTree (CFTok,[(CFCat, CFFun)]))
predefLexer groups = (reverse ruls, tcompile preds) where
(ruls,preds) = foldr mkOne ([],[]) groups
mkOne group@(cat,rules) (rs,ps) = (rule:rs,pre ++ ps) where
(rule,pre) = case partition isLexical rules of
([],_) -> (group,[])
(ls,rest) -> ((cat,rest), concatMap mkLexRule ls)
isLexical (f,(c,its)) = case its of
[CFTerm (RegAlts ws)] -> True
_ -> False
mkLexRule r = case r of
(fun,(cat,[CFTerm (RegAlts ws)])) -> [(w, [(cat,fun)]) | w <- ws]
_ -> []

206
src-3.0/GF/CF/ChartParser.hs
View File

@@ -1,206 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : ChartParser
-- Maintainer : Peter Ljunglöf
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:12 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.10 $
--
-- Bottom-up Kilbury chart parser from "Pure Functional Parsing", chapter 5.
-- OBSOLETE -- should use new MCFG parsers instead
-----------------------------------------------------------------------------
module GF.CF.ChartParser (chartParser) where
-- import Tracing
-- import PrintParser
-- import PrintSimplifiedTerm
import GF.Data.Operations
import GF.CF.CF
import GF.CF.CFIdent
import GF.CF.PPrCF (prCFItem)
import GF.Data.OrdSet
import GF.Data.OrdMap2
import Data.List (groupBy)
type Token = CFTok
type Name = CFFun
type Category = CFItem
type Grammar = ([Production], Terminal)
type Production = (Name, Category, [Category])
type Terminal = Token -> [(Category, Maybe Name)]
type GParser = Grammar -> Category -> [Token] -> ([ParseTree],String)
data ParseTree = Node Name Category [ParseTree] | Leaf Token
maxTake :: Int
-- maxTake = 1000
maxTake = maxBound
--------------------------------------------------
-- converting between GF parsing and CFG parsing
buildParser :: GParser -> CF -> CFCat -> CFParser
buildParser gparser cf = parse
where
parse = \start input ->
let parse2 = parse' (CFNonterm start) input in
(take maxTake [(parse2tree t, []) | t <- fst parse2], snd parse2)
parse' = gparser (cf2grammar cf)
cf2grammar :: CF -> Grammar
cf2grammar cf = (productions, terminal)
where
productions = [ (name, CFNonterm cat, rhs) |
(name, (cat, rhs)) <- cfRules ]
terminal tok = [ (CFNonterm cat, Just name) |
(cat, name) <- cfPredef tok ]
++
[ (item, Nothing) |
item <- elems rhsItems,
matchCFTerm item tok ]
cfRules = rulesOfCF cf
cfPredef = predefOfCF cf
rhsItems :: Set Category
rhsItems = union [ makeSet rhs | (_, (_, rhs)) <- cfRules ]
parse2tree :: ParseTree -> CFTree
parse2tree (Node name (CFNonterm cat) trees) = CFTree (name, (cat, trees'))
where
trees' = [ parse2tree t | t@(Node _ _ _) <- trees ] -- ignore leafs
maybeNode :: Maybe Name -> Category -> Token -> ParseTree
maybeNode (Just name) cat tok = Node name cat [Leaf tok]
maybeNode Nothing _ tok = Leaf tok
--------------------------------------------------
-- chart parsing (bottom up kilbury-like)
type Chart = [CState]
type CState = Set Edge
type Edge = (Int, Category, [Category])
type Passive = (Int, Int, Category)
chartParser :: CF -> CFCat -> CFParser
chartParser = buildParser chartParser0
chartParser0 :: GParser
chartParser0 (productions, terminal) = cparse
where
emptyCats :: Set Category
emptyCats = empties emptySet
where
empties cats | cats==cats' = cats
| otherwise = empties cats'
where cats' = makeSet [ cat | (_, cat, rhs) <- productions,
all (`elemSet` cats) rhs ]
grammarMap :: Map Category [(Name, [Category])]
grammarMap = makeMapWith (++)
[ (cat, [(name,rhs)]) | (name, cat, rhs) <- productions ]
leftCornerMap :: Map Category (Set (Category,[Category]))
leftCornerMap = makeMapWith (<++>) [ (a, unitSet (b, bs)) |
(_, b, abs) <- productions,
(a : bs) <- removeNullable abs ]
removeNullable :: [Category] -> [[Category]]
removeNullable [] = []
removeNullable cats@(cat:cats')
| cat `elemSet` emptyCats = cats : removeNullable cats'
| otherwise = [cats]
cparse :: Category -> [Token] -> ([ParseTree], String)
cparse start input = -- trace "ChartParser" $
case lookup (0, length input, start) $
-- tracePrt "#edgeTrees" (prt . map (length.snd)) $
edgeTrees of
Just trees -> -- tracePrt "#trees" (prt . length . fst) $
(trees, "Chart:" ++++ prChart passiveEdges)
Nothing -> ([], "Chart:" ++++ prChart passiveEdges)
where
finalChart :: Chart
finalChart = map buildState initialChart
finalChartMap :: [Map Category (Set Edge)]
finalChartMap = map stateMap finalChart
stateMap :: CState -> Map Category (Set Edge)
stateMap state = makeMapWith (<++>) [ (a, unitSet (i,b,bs)) |
(i, b, a:bs) <- elems state ]
initialChart :: Chart
initialChart = -- tracePrt "#initialChart" (prt . map (length.elems)) $
emptySet : map initialState (zip [0..] input)
where initialState (j, sym) = makeSet [ (j, cat, []) |
(cat, _) <- terminal sym ]
buildState :: CState -> CState
buildState = limit more
where more (j, a, []) = ordSet [ (j, b, bs) |
(b, bs) <- elems (lookupWith emptySet leftCornerMap a) ]
<++>
lookupWith emptySet (finalChartMap !! j) a
more (j, b, a:bs) = ordSet [ (j, b, bs) |
a `elemSet` emptyCats ]
passiveEdges :: [Passive]
passiveEdges = -- tracePrt "#passiveEdges" (prt . length) $
[ (i, j, cat) |
(j, state) <- zip [0..] $
-- tracePrt "#passiveChart"
-- (prt . map (length.filter (\(_,_,x)->null x).elems)) $
-- tracePrt "#activeChart" (prt . map (length.elems)) $
finalChart,
(i, cat, []) <- elems state ]
++
[ (i, i, cat) |
i <- [0 .. length input],
cat <- elems emptyCats ]
edgeTrees :: [ (Passive, [ParseTree]) ]
edgeTrees = [ (edge, treesFor edge) | edge <- passiveEdges ]
edgeTreesMap :: Map (Int, Category) [(Int, [ParseTree])]
edgeTreesMap = makeMapWith (++) [ ((i,c), [(j,trees)]) |
((i,j,c), trees) <- edgeTrees ]
treesFor :: Passive -> [ParseTree]
treesFor (i, j, cat) = [ Node name cat trees |
(name, rhs) <- lookupWith [] grammarMap cat,
trees <- children rhs i j ]
++
[ maybeNode name cat tok |
i == j-1,
let tok = input !! i,
Just name <- [lookup cat (terminal tok)] ]
children :: [Category] -> Int -> Int -> [[ParseTree]]
children [] i k = [ [] | i == k ]
children (c:cs) i k = [ tree : rest |
i <= k,
(j, trees) <- lookupWith [] edgeTreesMap (i,c),
rest <- children cs j k,
tree <- trees ]
{-
instance Print ParseTree where
prt (Node name cat trees) = prt name++"."++prt cat++"^{"++prtSep "," trees++"}"
prt (Leaf token) = prt token
-}
-- AR 10/12/2002
prChart :: [Passive] -> String
prChart = unlines . map (unwords . map prOne) . positions where
prOne (i,j,it) = show i ++ "-" ++ show j ++ "-" ++ prCFItem it
positions = groupBy (\ (i,_,_) (j,_,_) -> i == j)

191
src-3.0/GF/CF/EBNF.hs
View File

@@ -1,191 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : EBNF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:13 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.CF.EBNF (pEBNFasGrammar) where
import GF.Data.Operations
import GF.Data.Parsers
import GF.Infra.Comments
import GF.CF.CF
import GF.CF.CFIdent
import GF.Grammar.Grammar
import GF.Grammar.PrGrammar
import GF.CF.CFtoGrammar
import qualified GF.Source.AbsGF as A
import Data.List (nub, partition)
-- AR 18/4/2000 - 31/3/2004
-- Extended BNF grammar with token type a
-- put a = String for simple applications
type EBNF = [ERule]
type ERule = (ECat, ERHS)
type ECat = (String,[Int])
type ETok = String
ebnfID = "EBNF" ---- make this parametric!
data ERHS =
ETerm ETok
| ENonTerm ECat
| ESeq ERHS ERHS
| EAlt ERHS ERHS
| EStar ERHS
| EPlus ERHS
| EOpt ERHS
| EEmpty
type CFRHS = [CFItem]
type CFJustRule = (CFCat, CFRHS)
ebnf2gf :: EBNF -> [A.TopDef]
ebnf2gf = cf2grammar . rules2CF . ebnf2cf
ebnf2cf :: EBNF -> [CFRule]
ebnf2cf ebnf = [(mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
mkCFF i (CFCat (_,c), _) = string2CFFun ebnfID ("Mk" ++ prt c ++ "_" ++ show i)
normEBNF :: EBNF -> [CFJustRule]
normEBNF erules = let
erules1 = [normERule ([i],r) | (i,r) <- zip [0..] erules]
erules2 = erules1 ---refreshECats erules1 --- this seems to be just bad !
erules3 = concat (map pickERules erules2)
erules4 = nubERules erules3
in [(mkCFCatE cat, map eitem2cfitem its) | (cat,itss) <- erules3, its <- itss]
refreshECats :: [NormERule] -> [NormERule]
refreshECats rules = [recas [i] rule | (i,rule) <- zip [0..] rules] where
recas ii (cat,its) = (updECat ii cat, [recss ii 0 s | s <- its])
recss ii n [] = []
recss ii n (s:ss) = recit (ii ++ [n]) s : recss ii (n+1) ss
recit ii it = case it of
EINonTerm cat -> EINonTerm (updECat ii cat)
EIStar (cat,t) -> EIStar (updECat ii cat, [recss ii 0 s | s <- t])
EIPlus (cat,t) -> EIPlus (updECat ii cat, [recss ii 0 s | s <- t])
EIOpt (cat,t) -> EIOpt (updECat ii cat, [recss ii 0 s | s <- t])
_ -> it
pickERules :: NormERule -> [NormERule]
pickERules rule@(cat,alts) = rule : concat (map pics (concat alts)) where
pics it = case it of
EIStar ru@(cat,t) -> mkEStarRules cat ++ pickERules ru
EIPlus ru@(cat,t) -> mkEPlusRules cat ++ pickERules ru
EIOpt ru@(cat,t) -> mkEOptRules cat ++ pickERules ru
_ -> []
mkEStarRules cat = [(cat', [[],[EINonTerm cat, EINonTerm cat']])]
where cat' = mkNewECat cat "Star"
mkEPlusRules cat = [(cat', [[EINonTerm cat],[EINonTerm cat, EINonTerm cat']])]
where cat' = mkNewECat cat "Plus"
mkEOptRules cat = [(cat', [[],[EINonTerm cat]])]
where cat' = mkNewECat cat "Opt"
nubERules :: [NormERule] -> [NormERule]
nubERules rules = nub optim where
optim = map (substERules (map mkSubst replaces)) irreducibles
(replaces,irreducibles) = partition reducible rules
reducible (cat,[items]) = isNewCat cat && all isOldIt items
reducible _ = False
isNewCat (_,ints) = ints == []
isOldIt (EITerm _) = True
isOldIt (EINonTerm cat) = not (isNewCat cat)
isOldIt _ = False
mkSubst (cat,its) = (cat, head its) -- def of reducible: its must be singleton
--- the optimization assumes each cat has at most one EBNF rule.
substERules :: [(ECat,[EItem])] -> NormERule -> NormERule
substERules g (cat,itss) = (cat, map sub itss) where
sub [] = []
sub (i@(EINonTerm cat') : ii) = case lookup cat g of
Just its -> its ++ sub ii
_ -> i : sub ii
sub (EIStar r : ii) = EIStar (substERules g r) : ii
sub (EIPlus r : ii) = EIPlus (substERules g r) : ii
sub (EIOpt r : ii) = EIOpt (substERules g r) : ii
eitem2cfitem :: EItem -> CFItem
eitem2cfitem it = case it of
EITerm a -> atomCFTerm $ tS a
EINonTerm cat -> CFNonterm (mkCFCatE cat)
EIStar (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Star"))
EIPlus (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Plus"))
EIOpt (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Opt"))
type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items
data EItem =
EITerm String
| EINonTerm ECat
| EIStar NormERule
| EIPlus NormERule
| EIOpt NormERule
deriving Eq
normERule :: ([Int],ERule) -> NormERule
normERule (ii,(cat,rhs)) =
(cat,[map (mkEItem (ii ++ [i])) r' | (i,r') <- zip [0..] (disjNorm rhs)]) where
disjNorm r = case r of
ESeq r1 r2 -> [x ++ y | x <- disjNorm r1, y <- disjNorm r2]
EAlt r1 r2 -> disjNorm r1 ++ disjNorm r2
EEmpty -> [[]]
_ -> [[r]]
mkEItem :: [Int] -> ERHS -> EItem
mkEItem ii rhs = case rhs of
ETerm a -> EITerm a
ENonTerm cat -> EINonTerm cat
EStar r -> EIStar (normERule (ii,(mkECat ii, r)))
EPlus r -> EIPlus (normERule (ii,(mkECat ii, r)))
EOpt r -> EIOpt (normERule (ii,(mkECat ii, r)))
_ -> EINonTerm ("?????",[])
-- _ -> error "should not happen in ebnf" ---
mkECat ints = ("C", ints)
prECat (c,[]) = c
prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints)
mkCFCatE :: ECat -> CFCat
mkCFCatE = string2CFCat ebnfID . prECat
updECat _ (c,[]) = (c,[])
updECat ii (c,_) = (c,ii)
mkNewECat (c,ii) str = (c ++ str,ii)
------ parser for EBNF grammars
pEBNFasGrammar :: String -> Err [A.TopDef]
pEBNFasGrammar = parseResultErr (pEBNF *** ebnf2gf) . remComments
pEBNF :: Parser Char EBNF
pEBNF = longestOfMany (pJ pERule)
pERule :: Parser Char ERule
pERule = pECat ... pJ (literals ":=" ||| literals "::=") +.. pERHS 0 ..+ jL ";"
pERHS :: Int -> Parser Char ERHS
pERHS 0 = pTList "|" (pERHS 1) *** foldr1 EAlt
pERHS 1 = longestOfMany (pJ (pERHS 2)) *** foldr ESeq EEmpty
pERHS 2 = pERHS 3 ... pJ pUnaryEOp *** (\ (a,f) -> f a)
pERHS 3 = pQuotedString *** ETerm
||| pECat *** ENonTerm ||| pParenth (pERHS 0)
pUnaryEOp :: Parser Char (ERHS -> ERHS)
pUnaryEOp =
lits "*" <<< EStar ||| lits "+" <<< EPlus ||| lits "?" <<< EOpt ||| succeed id
pECat = pIdent *** (\c -> (c,[]))

102
src-3.0/GF/CF/PPrCF.hs
View File

@@ -1,102 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PPrCF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/15 17:56:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003
--
-- use the Print class instead!
-----------------------------------------------------------------------------
module GF.CF.PPrCF (prCF, prCFTree, prCFRule, prCFFun, prCFCat, prCFItem, prRegExp, pCF) where
import GF.Data.Operations
import GF.CF.CF
import GF.CF.CFIdent
import GF.Canon.AbsGFC
import GF.Grammar.PrGrammar
import Data.Char
import Data.List
prCF :: CF -> String
prCF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function
prCFTree :: CFTree -> String
prCFTree (CFTree (fun, (_,trees))) = prCFFun fun ++ prs trees where
prs [] = ""
prs ts = " " ++ unwords (map ps ts)
ps t@(CFTree (_,(_,[]))) = prCFTree t
ps t = prParenth (prCFTree t)
{-# NOINLINE prCFTree #-}
-- Workaround ghc 6.8.2 bug
prCFRule :: CFRule -> String
prCFRule (fun,(cat,its)) =
prCFFun fun ++ "." +++ prCFCat cat +++ "::=" +++
unwords (map prCFItem its) +++ ";"
prCFFun :: CFFun -> String
prCFFun = prCFFun' True ---- False -- print profiles for debug
prCFFun' :: Bool -> CFFun -> String
prCFFun' profs (CFFun (t, p)) = prt_ t ++ pp p where
pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p)
normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])]
prCFCat :: CFCat -> String
prCFCat (CFCat (c,l)) = prt_ c ++ case prt_ l of
"s" -> []
_ -> "-" ++ prt_ l ----
prCFItem :: CFItem -> String
prCFItem (CFNonterm c) = prCFCat c
prCFItem (CFTerm a) = prRegExp a
prRegExp :: RegExp -> String
prRegExp (RegAlts tt) = case tt of
[t] -> prQuotedString t
_ -> prParenth (prTList " | " (map prQuotedString tt))
-- rules have an amazingly easy parser, if we use the format
-- fun. C -> item1 item2 ... where unquoted items are treated as cats
-- Actually would be nice to add profiles to this.
getCFRule :: String -> String -> Err [CFRule]
getCFRule mo s = getcf (wrds s) where
getcf ws = case ws of
fun : cat : a : its | isArrow a ->
Ok [(string2CFFun mo (init fun),
(string2CFCat mo cat, map mkIt its))]
cat : a : its | isArrow a ->
Ok [(string2CFFun mo (mkFun cat it),
(string2CFCat mo cat, map mkIt it)) | it <- chunk its]
_ -> Bad (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="]
mkIt w = case w of
('"':w@(_:_)) -> atomCFTerm (string2CFTok (init w))
_ -> CFNonterm (string2CFCat mo w)
chunk its = case its of
[] -> [[]]
_ -> chunks "|" its
mkFun cat its = case its of
[] -> cat ++ "_"
_ -> concat $ intersperse "_" (cat : map clean its) -- CLE style
clean = filter isAlphaNum -- to form valid identifiers
wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
pCF :: String -> String -> Err [CFRule]
pCF mo s = do
rules <- mapM (getCFRule mo) $ filter isRule $ lines s
return $ concat rules
where
isRule line = case dropWhile isSpace line of
'-':'-':_ -> False
_ -> not $ all isSpace line

150
src-3.0/GF/CF/PrLBNF.hs
View File

@@ -1,150 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PrLBNF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 14:15:16 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.11 $
--
-- 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.
-- With primitive error messaging, by rules and rule tails commented out
-----------------------------------------------------------------------------
module GF.CF.PrLBNF (prLBNF,prBNF) where
import GF.CF.CF
import GF.CF.CFIdent
import GF.Canon.AbsGFC
import GF.Infra.Ident
import GF.Grammar.PrGrammar
import GF.Compile.ShellState
import GF.Canon.GFC
import GF.Canon.Look
import GF.Data.Operations
import GF.Infra.Modules
import Data.Char
import Data.List (nub)
prLBNF :: Bool -> StateGrammar -> String
prLBNF new gr = unlines $ pragmas ++ (map (prCFRule cs) rules')
where
cs = map IC ["Int","String"] ++ [catIdPlus c | (_,(c,_)) <- rules]
cf = stateCF gr
(pragmas,rules) = if new -- tries to treat precedence levels
then mkLBNF (stateGrammarST gr) $ rulesOfCF cf
else ([],rulesOfCF cf) -- "normal" behaviour
rules' = concatMap expand rules
expand (f,(c,its)) = [(f,(c,it)) | it <- combinations (map expIt its)]
expIt i = case i of
CFTerm (RegAlts ss) -> [CFTerm (RegAlts [s]) | s <- ss]
_ -> [i]
-- | a hack to hide the LBNF details
prBNF :: Bool -> StateGrammar -> String
prBNF b = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF b
where
unLBNF r = case r of
"---":ts -> ts
";":"---":ts -> ts
c:ts -> c : unLBNF ts
_ -> r
--- | awful low level code without abstraction over label names etc
mkLBNF :: CanonGrammar -> [CFRule] -> ([String],[CFRule])
mkLBNF gr rules = (coercions, nub $ concatMap mkRule rules) where
coercions = ["coercions" +++ prt_ c +++ show n +++ ";" |
(_,ModMod m) <- modules gr,
(c,CncCat (RecType ls) _ _) <- tree2list $ jments m,
Lbg (L (IC "p")) (TInts n) <- ls
]
precedences = [(f,(prec,assoc)) |
(_,ModMod m) <- modules gr,
(f,CncFun _ _ (R lin) _) <- tree2list $ jments m,
(Just prec, Just assoc) <- [(
lookup "p" [(lab,p) | Ass (L (IC lab)) (EInt p) <- lin],
lookup "a" [(lab,a) | Ass (L (IC lab)) (Par (CIQ _ (IC a)) []) <- lin]
)]
]
precfuns = map fst precedences
mkRule r@(fun@(CFFun (t, p)),(cat,its)) = case t of
AC (CIQ _ c) -> case lookup c precedences of
Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))]
_ -> return r
AD (CIQ _ c) -> case lookup c precedences of
Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))]
_ -> return r
_ -> return r
mkIts cat prec assoc i its = case its of
CFTerm (RegAlts ["("]):n@(CFNonterm k):CFTerm (RegAlts [")"]):rest | k==cat ->
mkIts cat prec assoc i $ n:rest -- remove variants with parentheses
CFNonterm k:rest | k==cat ->
CFNonterm (mkNonterm prec assoc i k) : mkIts cat prec assoc (i+1) rest
it:rest -> it:mkIts cat prec assoc i rest
[] -> []
mkCat prec (CFCat ((CIQ m (IC c)),l)) = CFCat ((CIQ m (IC (c ++ show prec ++ "+"))),l)
mkNonterm prec assoc i cat = mkCat prec' cat
where
prec' = case (assoc,i) of
("PL",0) -> prec
("PR",0) -> prec + 1
("PR",_) -> prec
_ -> prec + 1
catId ((CFCat ((CIQ _ c),l))) = c
catIdPlus ((CFCat ((CIQ _ c@(IC s)),l))) = case reverse s of
'+':cs -> IC $ reverse $ dropWhile isDigit cs
_ -> c
prCFRule :: [Ident] -> CFRule -> String
prCFRule cs (fun,(cat,its)) =
prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax
unwords (map (prCFItem cs) its) +++ ";"
prCFFun :: CFCat -> CFFun -> String
prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of
AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
_ -> prErr True $ prt t
where
lab = prLab l
f2 f = if null lab then "" else f
prP = concatMap show
prId b i = case i of
IC "Int" -> "Integer"
IC "#Var" -> "Ident"
IC "Var" -> "Ident"
IC "id_" -> "_"
IC s@(c:_) | last s == '+' -> init s -- hack to save precedence information
IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else ""
_ -> prErr b $ prt i
prLab i = case i of
L (IC "s") -> "" ---
L (IC "_") -> "" ---
_ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else ""
-- | just comment out the rest if you cannot interpret the function name in LBNF
-- two versions, depending on whether in the beginning of a rule or elsewhere;
-- in the latter case, error just terminates the rule
prErr :: Bool -> String -> String
prErr b s = (if b then "" else " ;") +++ "---" +++ s
prCFCat :: Bool -> CFCat -> String
prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ----
-- | if a category does not have a production of its own, we replace it by Ident
prCFItem cs (CFNonterm c) = if elem (catIdPlus c) cs then prCFCat False c else "Ident"
prCFItem _ (CFTerm a) = prRegExp a
prRegExp (RegAlts tt) = case tt of
[t] -> prQuotedString t
_ -> prErr False $ prParenth (prTList " | " (map prQuotedString tt))

106
src-3.0/GF/CF/Profile.hs
View File

@@ -1,106 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Profile
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:14 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001
-- revised 8/4/2002 for the new profile structure
-----------------------------------------------------------------------------
module GF.CF.Profile (postParse) where
import GF.Canon.AbsGFC
import GF.Canon.GFC
import qualified GF.Infra.Ident as I
import GF.Canon.CMacros
---import MMacros
import GF.CF.CF
import GF.CF.CFIdent
import GF.CF.PPrCF -- for error msg
import GF.Grammar.PrGrammar
import GF.Data.Operations
import Control.Monad
import Data.List (nub)
-- | the job is done in two passes:
--
-- 1. tree2term: restore constituent order from Profile
--
-- 2. term2trm: restore Bindings from Binds
postParse :: CFTree -> Err Exp
postParse tree = do
iterm <- errIn ("postprocessing parse tree" +++ prCFTree tree) $ tree2term tree
return $ term2trm iterm
-- | an intermediate data structure
data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta deriving (Eq,Show)
type BindVs = [[I.Ident]]
-- | (1) restore constituent order from Profile
tree2term :: CFTree -> Err ITerm
-- tree2term (CFTree (f,(_,[t]))) | f == dummyCFFun = tree2term t -- not used
tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of
AM _ -> return IMeta
_ -> do
args <- mapM mkArg pro
binds <- mapM mkBinds pro
return $ ITerm (fun, binds) args
where
mkArg (_,arg) = case arg of
[x] -> do -- one occurrence
trx <- trees !? x
tree2term trx
[] -> return IMeta -- suppression
_ -> do -- reduplication
trees' <- mapM (trees !?) arg
xs1 <- mapM tree2term trees'
xs2 <- checkArity xs1
unif xs2
checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1
then Bad "arity error"
else return xs'
where xs' = [t | t@(ITerm _ _) <- xs]
unif xs = case [t | t@(ITerm _ _) <- xs] of
[] -> return $ IMeta
(ITerm fp@(f,_) xx : ts) -> do
let hs = [h | ITerm (h,_) _ <- ts, h /= f]
testErr (null hs) -- if fails, hs must be nonempty
("unification expects" +++ prt f +++ "but found" +++ prt (head hs))
xx' <- mapM unifArg [0 .. length xx - 1]
return $ ITerm fp xx'
where
unifArg i = unif [zz !! i | ITerm _ zz <- xs]
mkBinds (xss,_) = mapM mkBind xss
mkBind xs = do
ts <- mapM (trees !?) xs
let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts]
testErr (length ts == length vs) "non-variable in bound position"
case vs of
[x] -> return x
[] -> return $ I.identC "h_" ---- uBoundVar
y:ys -> do
testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y)
return y
-- | (2) restore Bindings from Binds
term2trm :: ITerm -> Exp
term2trm IMeta = EAtom (AM 0) ---- mExp0
term2trm (ITerm (fun, binds) terms) =
let bterms = zip binds terms
in mkAppAtom fun [mkAbsR xs (term2trm t) | (xs,t) <- bterms]
--- these are deprecated
where
mkAbsR c e = foldr EAbs e c
mkAppAtom a = mkApp (EAtom a)
mkApp = foldl EApp

45
src-3.0/GF/CFGM/AbsCFG.hs
View File

@@ -1,45 +0,0 @@
module GF.CFGM.AbsCFG where
-- Haskell module generated by the BNF converter
newtype Ident = Ident String deriving (Eq,Ord,Show)
newtype SingleQuoteString = SingleQuoteString String deriving (Eq,Ord,Show)
data Grammars =
Grammars [Grammar]
deriving (Eq,Ord,Show)
data Grammar =
Grammar Ident [Flag] [Rule]
deriving (Eq,Ord,Show)
data Flag =
StartCat Category
deriving (Eq,Ord,Show)
data Rule =
Rule Fun Profiles Category [Symbol]
deriving (Eq,Ord,Show)
data Fun =
Cons Ident
| Coerce
deriving (Eq,Ord,Show)
data Profiles =
Profiles [Profile]
deriving (Eq,Ord,Show)
data Profile =
UnifyProfile [Integer]
| ConstProfile Ident
deriving (Eq,Ord,Show)
data Symbol =
CatS Category
| TermS String
deriving (Eq,Ord,Show)
data Category =
Category SingleQuoteString
deriving (Eq,Ord,Show)

36
src-3.0/GF/CFGM/CFG.cf
View File

@@ -1,36 +0,0 @@
entrypoints Grammars;
Grammars. Grammars ::= [Grammar];
Grammar. Grammar ::= "grammar" Ident [Flag] [Rule] "end" "grammar";
separator Grammar "";
StartCat. Flag ::= "startcat" Category;
terminator Flag ";";
Rule. Rule ::= Fun ":" Profiles "." Category "->" [Symbol];
terminator Rule ";";
Cons. Fun ::= Ident ;
Coerce. Fun ::= "_" ;
Profiles. Profiles ::= "[" [Profile] "]";
separator Profile ",";
UnifyProfile. Profile ::= "[" [Integer] "]";
ConstProfile. Profile ::= Ident ;
separator Integer ",";
CatS. Symbol ::= Category;
TermS. Symbol ::= String;
-- separator Symbol "";
[]. [Symbol] ::= "." ;
(:[]). [Symbol] ::= Symbol ;
(:). [Symbol] ::= Symbol [Symbol] ;
Category. Category ::= SingleQuoteString ;
token SingleQuoteString '\'' ((char - ["'\\"]) | ('\\' ["'\\"]))* '\'' ;

312
src-3.0/GF/CFGM/LexCFG.hs
View File

File diff suppressed because one or more lines are too long

135
src-3.0/GF/CFGM/LexCFG.x
View File

@@ -1,135 +0,0 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
module LexCFG where
import ErrM
}
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
$d = [0-9] -- digit
$i = [$l $d _ '] -- identifier character
$u = [\0-\255] -- universal: any character
@rsyms = -- reserved words consisting of special symbols
\; | \: | \. | \- \> | \_ | \[ | \] | \,
:-
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
\' ($u # [\' \\]| \\ [\' \\]) * \' { tok (\p s -> PT p (eitherResIdent (T_SingleQuoteString . share) s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
{
tok f p s = f p s
share :: String -> String
share = id
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
| T_SingleQuoteString !String
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of
PT _ (TS s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
PT _ (T_SingleQuoteString s) -> s
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords = b "grammar" (b "end" N N) (b "startcat" N N)
where b s = B s (TS s)
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type AlexInput = (Posn, -- current position,
Char, -- previous char
String) -- current input string
tokens :: String -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: (Posn, Char, String) -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, c, []) = Nothing
alexGetChar (p, _, (c:s)) =
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
}

779
src-3.0/GF/CFGM/ParCFG.hs
View File

@@ -1,779 +0,0 @@
{-# OPTIONS -fglasgow-exts -cpp #-}
module GF.CFGM.ParCFG where
import GF.CFGM.AbsCFG
import GF.CFGM.LexCFG
import GF.Data.ErrM
import Array
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts
#else
import GlaExts
#endif
-- parser produced by Happy Version 1.15
newtype HappyAbsSyn = HappyAbsSyn (() -> ())
happyIn4 :: (Ident) -> (HappyAbsSyn )
happyIn4 x = unsafeCoerce# x
{-# INLINE happyIn4 #-}
happyOut4 :: (HappyAbsSyn ) -> (Ident)
happyOut4 x = unsafeCoerce# x
{-# INLINE happyOut4 #-}
happyIn5 :: (Integer) -> (HappyAbsSyn )
happyIn5 x = unsafeCoerce# x
{-# INLINE happyIn5 #-}
happyOut5 :: (HappyAbsSyn ) -> (Integer)
happyOut5 x = unsafeCoerce# x
{-# INLINE happyOut5 #-}
happyIn6 :: (String) -> (HappyAbsSyn )
happyIn6 x = unsafeCoerce# x
{-# INLINE happyIn6 #-}
happyOut6 :: (HappyAbsSyn ) -> (String)
happyOut6 x = unsafeCoerce# x
{-# INLINE happyOut6 #-}
happyIn7 :: (SingleQuoteString) -> (HappyAbsSyn )
happyIn7 x = unsafeCoerce# x
{-# INLINE happyIn7 #-}
happyOut7 :: (HappyAbsSyn ) -> (SingleQuoteString)
happyOut7 x = unsafeCoerce# x
{-# INLINE happyOut7 #-}
happyIn8 :: (Grammars) -> (HappyAbsSyn )
happyIn8 x = unsafeCoerce# x
{-# INLINE happyIn8 #-}
happyOut8 :: (HappyAbsSyn ) -> (Grammars)
happyOut8 x = unsafeCoerce# x
{-# INLINE happyOut8 #-}
happyIn9 :: (Grammar) -> (HappyAbsSyn )
happyIn9 x = unsafeCoerce# x
{-# INLINE happyIn9 #-}
happyOut9 :: (HappyAbsSyn ) -> (Grammar)
happyOut9 x = unsafeCoerce# x
{-# INLINE happyOut9 #-}
happyIn10 :: ([Grammar]) -> (HappyAbsSyn )
happyIn10 x = unsafeCoerce# x
{-# INLINE happyIn10 #-}
happyOut10 :: (HappyAbsSyn ) -> ([Grammar])
happyOut10 x = unsafeCoerce# x
{-# INLINE happyOut10 #-}
happyIn11 :: (Flag) -> (HappyAbsSyn )
happyIn11 x = unsafeCoerce# x
{-# INLINE happyIn11 #-}
happyOut11 :: (HappyAbsSyn ) -> (Flag)
happyOut11 x = unsafeCoerce# x
{-# INLINE happyOut11 #-}
happyIn12 :: ([Flag]) -> (HappyAbsSyn )
happyIn12 x = unsafeCoerce# x
{-# INLINE happyIn12 #-}
happyOut12 :: (HappyAbsSyn ) -> ([Flag])
happyOut12 x = unsafeCoerce# x
{-# INLINE happyOut12 #-}
happyIn13 :: (Rule) -> (HappyAbsSyn )
happyIn13 x = unsafeCoerce# x
{-# INLINE happyIn13 #-}
happyOut13 :: (HappyAbsSyn ) -> (Rule)
happyOut13 x = unsafeCoerce# x
{-# INLINE happyOut13 #-}
happyIn14 :: ([Rule]) -> (HappyAbsSyn )
happyIn14 x = unsafeCoerce# x
{-# INLINE happyIn14 #-}
happyOut14 :: (HappyAbsSyn ) -> ([Rule])
happyOut14 x = unsafeCoerce# x
{-# INLINE happyOut14 #-}
happyIn15 :: (Fun) -> (HappyAbsSyn )
happyIn15 x = unsafeCoerce# x
{-# INLINE happyIn15 #-}
happyOut15 :: (HappyAbsSyn ) -> (Fun)
happyOut15 x = unsafeCoerce# x
{-# INLINE happyOut15 #-}
happyIn16 :: (Profiles) -> (HappyAbsSyn )
happyIn16 x = unsafeCoerce# x
{-# INLINE happyIn16 #-}
happyOut16 :: (HappyAbsSyn ) -> (Profiles)
happyOut16 x = unsafeCoerce# x
{-# INLINE happyOut16 #-}
happyIn17 :: ([Profile]) -> (HappyAbsSyn )
happyIn17 x = unsafeCoerce# x
{-# INLINE happyIn17 #-}
happyOut17 :: (HappyAbsSyn ) -> ([Profile])
happyOut17 x = unsafeCoerce# x
{-# INLINE happyOut17 #-}
happyIn18 :: (Profile) -> (HappyAbsSyn )
happyIn18 x = unsafeCoerce# x
{-# INLINE happyIn18 #-}
happyOut18 :: (HappyAbsSyn ) -> (Profile)
happyOut18 x = unsafeCoerce# x
{-# INLINE happyOut18 #-}
happyIn19 :: ([Integer]) -> (HappyAbsSyn )
happyIn19 x = unsafeCoerce# x
{-# INLINE happyIn19 #-}
happyOut19 :: (HappyAbsSyn ) -> ([Integer])
happyOut19 x = unsafeCoerce# x
{-# INLINE happyOut19 #-}
happyIn20 :: (Symbol) -> (HappyAbsSyn )
happyIn20 x = unsafeCoerce# x
{-# INLINE happyIn20 #-}
happyOut20 :: (HappyAbsSyn ) -> (Symbol)
happyOut20 x = unsafeCoerce# x
{-# INLINE happyOut20 #-}
happyIn21 :: ([Symbol]) -> (HappyAbsSyn )
happyIn21 x = unsafeCoerce# x
{-# INLINE happyIn21 #-}
happyOut21 :: (HappyAbsSyn ) -> ([Symbol])
happyOut21 x = unsafeCoerce# x
{-# INLINE happyOut21 #-}
happyIn22 :: (Category) -> (HappyAbsSyn )
happyIn22 x = unsafeCoerce# x
{-# INLINE happyIn22 #-}
happyOut22 :: (HappyAbsSyn ) -> (Category)
happyOut22 x = unsafeCoerce# x
{-# INLINE happyOut22 #-}
happyInTok :: Token -> (HappyAbsSyn )
happyInTok x = unsafeCoerce# x
{-# INLINE happyInTok #-}
happyOutTok :: (HappyAbsSyn ) -> Token
happyOutTok x = unsafeCoerce# x
{-# INLINE happyOutTok #-}
happyActOffsets :: HappyAddr
happyActOffsets = HappyA# "\x00\x00\x36\x00\x00\x00\x29\x00\x35\x00\x00\x00\x32\x00\x00\x00\x30\x00\x38\x00\x19\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x34\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x31\x00\xfd\xff\x00\x00\x2c\x00\x2a\x00\x23\x00\x22\x00\x2b\x00\x25\x00\x20\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
happyGotoOffsets :: HappyAddr
happyGotoOffsets = HappyA# "\x28\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x21\x00\x05\x00\x01\x00\x00\x00\x1d\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x02\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
happyDefActions :: HappyAddr
happyDefActions = HappyA# "\xf8\xff\x00\x00\xfe\xff\x00\x00\xfa\xff\xf7\xff\x00\x00\xf5\xff\xf2\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xf6\xff\xfb\xff\xf0\xff\x00\x00\x00\x00\xef\xff\x00\x00\xf4\xff\xf9\xff\x00\x00\xf1\xff\x00\x00\xed\xff\xe9\xff\x00\x00\xec\xff\xe8\xff\x00\x00\x00\x00\xe7\xff\x00\x00\xfd\xff\xed\xff\xee\xff\xeb\xff\xea\xff\xe8\xff\x00\x00\xe4\xff\xe2\xff\xf3\xff\xe5\xff\xe3\xff\xfc\xff\xe6\xff\xe1\xff"#
happyCheck :: HappyAddr
happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x06\x00\x02\x00\x03\x00\x03\x00\x03\x00\x07\x00\x0c\x00\x00\x00\x0a\x00\x00\x00\x08\x00\x01\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x12\x00\x12\x00\x0d\x00\x0e\x00\x0d\x00\x0e\x00\x01\x00\x0f\x00\x00\x00\x05\x00\x03\x00\x0c\x00\x00\x00\x09\x00\x05\x00\x0d\x00\x0c\x00\x09\x00\x07\x00\x0b\x00\x0f\x00\x0e\x00\x0f\x00\x04\x00\x08\x00\x06\x00\x04\x00\x0d\x00\x0f\x00\x08\x00\x07\x00\x03\x00\x06\x00\x02\x00\x0a\x00\x01\x00\x01\x00\x11\x00\x0b\x00\xff\xff\x0f\x00\x0c\x00\x0a\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
happyTable :: HappyAddr
happyTable = HappyA# "\x00\x00\x29\x00\x0c\x00\x1e\x00\x29\x00\x0c\x00\x0c\x00\x0c\x00\x09\x00\x03\x00\x1a\x00\x0a\x00\x1a\x00\x08\x00\x20\x00\x2a\x00\x30\x00\x2c\x00\x2a\x00\x2b\x00\x2c\x00\x1f\x00\x0d\x00\x25\x00\x1c\x00\x1b\x00\x1c\x00\x20\x00\x2f\x00\x0f\x00\x13\x00\x2e\x00\x18\x00\x07\x00\x14\x00\x05\x00\x23\x00\x03\x00\x10\x00\x27\x00\x11\x00\x21\x00\x2f\x00\x0f\x00\x03\x00\x28\x00\x04\x00\x29\x00\x23\x00\x0f\x00\x24\x00\x25\x00\x1f\x00\x1a\x00\x17\x00\x16\x00\x18\x00\x15\x00\xff\xff\x0c\x00\x00\x00\x0f\x00\x03\x00\x07\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
happyReduceArr = array (1, 31) [
(1 , happyReduce_1),
(2 , happyReduce_2),
(3 , happyReduce_3),
(4 , happyReduce_4),
(5 , happyReduce_5),
(6 , happyReduce_6),
(7 , happyReduce_7),
(8 , happyReduce_8),
(9 , happyReduce_9),
(10 , happyReduce_10),
(11 , happyReduce_11),
(12 , happyReduce_12),
(13 , happyReduce_13),
(14 , happyReduce_14),
(15 , happyReduce_15),
(16 , happyReduce_16),
(17 , happyReduce_17),
(18 , happyReduce_18),
(19 , happyReduce_19),
(20 , happyReduce_20),
(21 , happyReduce_21),
(22 , happyReduce_22),
(23 , happyReduce_23),
(24 , happyReduce_24),
(25 , happyReduce_25),
(26 , happyReduce_26),
(27 , happyReduce_27),
(28 , happyReduce_28),
(29 , happyReduce_29),
(30 , happyReduce_30),
(31 , happyReduce_31)
]
happy_n_terms = 18 :: Int
happy_n_nonterms = 19 :: Int
happyReduce_1 = happySpecReduce_1 0# happyReduction_1
happyReduction_1 happy_x_1
= case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) ->
happyIn4
(Ident happy_var_1
)}
happyReduce_2 = happySpecReduce_1 1# happyReduction_2
happyReduction_2 happy_x_1
= case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) ->
happyIn5
((read happy_var_1) :: Integer
)}
happyReduce_3 = happySpecReduce_1 2# happyReduction_3
happyReduction_3 happy_x_1
= case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) ->
happyIn6
(happy_var_1
)}
happyReduce_4 = happySpecReduce_1 3# happyReduction_4
happyReduction_4 happy_x_1
= case happyOutTok happy_x_1 of { (PT _ (T_SingleQuoteString happy_var_1)) ->
happyIn7
(SingleQuoteString (happy_var_1)
)}
happyReduce_5 = happySpecReduce_1 4# happyReduction_5
happyReduction_5 happy_x_1
= case happyOut10 happy_x_1 of { happy_var_1 ->
happyIn8
(Grammars (reverse happy_var_1)
)}
happyReduce_6 = happyReduce 6# 5# happyReduction_6
happyReduction_6 (happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut4 happy_x_2 of { happy_var_2 ->
case happyOut12 happy_x_3 of { happy_var_3 ->
case happyOut14 happy_x_4 of { happy_var_4 ->
happyIn9
(Grammar happy_var_2 (reverse happy_var_3) (reverse happy_var_4)
) `HappyStk` happyRest}}}
happyReduce_7 = happySpecReduce_0 6# happyReduction_7
happyReduction_7 = happyIn10
([]
)
happyReduce_8 = happySpecReduce_2 6# happyReduction_8
happyReduction_8 happy_x_2
happy_x_1
= case happyOut10 happy_x_1 of { happy_var_1 ->
case happyOut9 happy_x_2 of { happy_var_2 ->
happyIn10
(flip (:) happy_var_1 happy_var_2
)}}
happyReduce_9 = happySpecReduce_2 7# happyReduction_9
happyReduction_9 happy_x_2
happy_x_1
= case happyOut22 happy_x_2 of { happy_var_2 ->
happyIn11
(StartCat happy_var_2
)}
happyReduce_10 = happySpecReduce_0 8# happyReduction_10
happyReduction_10 = happyIn12
([]
)
happyReduce_11 = happySpecReduce_3 8# happyReduction_11
happyReduction_11 happy_x_3
happy_x_2
happy_x_1
= case happyOut12 happy_x_1 of { happy_var_1 ->
case happyOut11 happy_x_2 of { happy_var_2 ->
happyIn12
(flip (:) happy_var_1 happy_var_2
)}}
happyReduce_12 = happyReduce 7# 9# happyReduction_12
happyReduction_12 (happy_x_7 `HappyStk`
happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut15 happy_x_1 of { happy_var_1 ->
case happyOut16 happy_x_3 of { happy_var_3 ->
case happyOut22 happy_x_5 of { happy_var_5 ->
case happyOut21 happy_x_7 of { happy_var_7 ->
happyIn13
(Rule happy_var_1 happy_var_3 happy_var_5 happy_var_7
) `HappyStk` happyRest}}}}
happyReduce_13 = happySpecReduce_0 10# happyReduction_13
happyReduction_13 = happyIn14
([]
)
happyReduce_14 = happySpecReduce_3 10# happyReduction_14
happyReduction_14 happy_x_3
happy_x_2
happy_x_1
= case happyOut14 happy_x_1 of { happy_var_1 ->
case happyOut13 happy_x_2 of { happy_var_2 ->
happyIn14
(flip (:) happy_var_1 happy_var_2
)}}
happyReduce_15 = happySpecReduce_1 11# happyReduction_15
happyReduction_15 happy_x_1
= case happyOut4 happy_x_1 of { happy_var_1 ->
happyIn15
(Cons happy_var_1
)}
happyReduce_16 = happySpecReduce_1 11# happyReduction_16
happyReduction_16 happy_x_1
= happyIn15
(Coerce
)
happyReduce_17 = happySpecReduce_3 12# happyReduction_17
happyReduction_17 happy_x_3
happy_x_2
happy_x_1
= case happyOut17 happy_x_2 of { happy_var_2 ->
happyIn16
(Profiles happy_var_2
)}
happyReduce_18 = happySpecReduce_0 13# happyReduction_18
happyReduction_18 = happyIn17
([]
)
happyReduce_19 = happySpecReduce_1 13# happyReduction_19
happyReduction_19 happy_x_1
= case happyOut18 happy_x_1 of { happy_var_1 ->
happyIn17
((:[]) happy_var_1
)}
happyReduce_20 = happySpecReduce_3 13# happyReduction_20
happyReduction_20 happy_x_3
happy_x_2
happy_x_1
= case happyOut18 happy_x_1 of { happy_var_1 ->
case happyOut17 happy_x_3 of { happy_var_3 ->
happyIn17
((:) happy_var_1 happy_var_3
)}}
happyReduce_21 = happySpecReduce_3 14# happyReduction_21
happyReduction_21 happy_x_3
happy_x_2
happy_x_1
= case happyOut19 happy_x_2 of { happy_var_2 ->
happyIn18
(UnifyProfile happy_var_2
)}
happyReduce_22 = happySpecReduce_1 14# happyReduction_22
happyReduction_22 happy_x_1
= case happyOut4 happy_x_1 of { happy_var_1 ->
happyIn18
(ConstProfile happy_var_1
)}
happyReduce_23 = happySpecReduce_0 15# happyReduction_23
happyReduction_23 = happyIn19
([]
)
happyReduce_24 = happySpecReduce_1 15# happyReduction_24
happyReduction_24 happy_x_1
= case happyOut5 happy_x_1 of { happy_var_1 ->
happyIn19
((:[]) happy_var_1
)}
happyReduce_25 = happySpecReduce_3 15# happyReduction_25
happyReduction_25 happy_x_3
happy_x_2
happy_x_1
= case happyOut5 happy_x_1 of { happy_var_1 ->
case happyOut19 happy_x_3 of { happy_var_3 ->
happyIn19
((:) happy_var_1 happy_var_3
)}}
happyReduce_26 = happySpecReduce_1 16# happyReduction_26
happyReduction_26 happy_x_1
= case happyOut22 happy_x_1 of { happy_var_1 ->
happyIn20
(CatS happy_var_1
)}
happyReduce_27 = happySpecReduce_1 16# happyReduction_27
happyReduction_27 happy_x_1
= case happyOut6 happy_x_1 of { happy_var_1 ->
happyIn20
(TermS happy_var_1
)}
happyReduce_28 = happySpecReduce_1 17# happyReduction_28
happyReduction_28 happy_x_1
= happyIn21
([]
)
happyReduce_29 = happySpecReduce_1 17# happyReduction_29
happyReduction_29 happy_x_1
= case happyOut20 happy_x_1 of { happy_var_1 ->
happyIn21
((:[]) happy_var_1
)}
happyReduce_30 = happySpecReduce_2 17# happyReduction_30
happyReduction_30 happy_x_2
happy_x_1
= case happyOut20 happy_x_1 of { happy_var_1 ->
case happyOut21 happy_x_2 of { happy_var_2 ->
happyIn21
((:) happy_var_1 happy_var_2
)}}
happyReduce_31 = happySpecReduce_1 18# happyReduction_31
happyReduction_31 happy_x_1
= case happyOut7 happy_x_1 of { happy_var_1 ->
happyIn22
(Category happy_var_1
)}
happyNewToken action sts stk [] =
happyDoAction 17# (error "reading EOF!") action sts stk []
happyNewToken action sts stk (tk:tks) =
let cont i = happyDoAction i tk action sts stk tks in
case tk of {
PT _ (TS ";") -> cont 1#;
PT _ (TS ":") -> cont 2#;
PT _ (TS ".") -> cont 3#;
PT _ (TS "->") -> cont 4#;
PT _ (TS "_") -> cont 5#;
PT _ (TS "[") -> cont 6#;
PT _ (TS "]") -> cont 7#;
PT _ (TS ",") -> cont 8#;
PT _ (TS "end") -> cont 9#;
PT _ (TS "grammar") -> cont 10#;
PT _ (TS "startcat") -> cont 11#;
PT _ (TV happy_dollar_dollar) -> cont 12#;
PT _ (TI happy_dollar_dollar) -> cont 13#;
PT _ (TL happy_dollar_dollar) -> cont 14#;
PT _ (T_SingleQuoteString happy_dollar_dollar) -> cont 15#;
_ -> cont 16#;
_ -> happyError' (tk:tks)
}
happyError_ tk tks = happyError' (tk:tks)
happyThen :: () => Err a -> (a -> Err b) -> Err b
happyThen = (thenM)
happyReturn :: () => a -> Err a
happyReturn = (returnM)
happyThen1 m k tks = (thenM) m (\a -> k a tks)
happyReturn1 :: () => a -> b -> Err a
happyReturn1 = \a tks -> (returnM) a
happyError' :: () => [Token] -> Err a
happyError' = happyError
pGrammars tks = happySomeParser where
happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut8 x))
happySeq = happyDontSeq
returnM :: a -> Err a
returnM = return
thenM :: Err a -> (a -> Err b) -> Err b
thenM = (>>=)
happyError :: [Token] -> Err a
happyError ts =
Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
myLexer = tokens
{-# LINE 1 "GenericTemplate.hs" #-}
-- $Id: ParCFG.hs,v 1.8 2005/05/17 14:04:37 bringert Exp $
{-# LINE 27 "GenericTemplate.hs" #-}
data Happy_IntList = HappyCons Int# Happy_IntList
infixr 9 `HappyStk`
data HappyStk a = HappyStk a (HappyStk a)
-----------------------------------------------------------------------------
-- starting the parse
happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
-----------------------------------------------------------------------------
-- Accepting the parse
-- If the current token is 0#, it means we've just accepted a partial
-- parse (a %partial parser). We must ignore the saved token on the top of
-- the stack in this case.
happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =
happyReturn1 ans
happyAccept j tk st sts (HappyStk ans _) =
(happyTcHack j (happyTcHack st)) (happyReturn1 ans)
-----------------------------------------------------------------------------
-- Arrays only: do the next action
happyDoAction i tk st
= {- nothing -}
case action of
0# -> {- nothing -}
happyFail i tk st
-1# -> {- nothing -}
happyAccept i tk st
n | (n <# (0# :: Int#)) -> {- nothing -}
(happyReduceArr ! rule) i tk st
where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))
n -> {- nothing -}
happyShift new_state i tk st
where new_state = (n -# (1# :: Int#))
where off = indexShortOffAddr happyActOffsets st
off_i = (off +# i)
check = if (off_i >=# (0# :: Int#))
then (indexShortOffAddr happyCheck off_i ==# i)
else False
action | check = indexShortOffAddr happyTable off_i
| otherwise = indexShortOffAddr happyDefActions st
indexShortOffAddr (HappyA# arr) off =
#if __GLASGOW_HASKELL__ > 500
narrow16Int# i
#elif __GLASGOW_HASKELL__ == 500
intToInt16# i
#else
(i `iShiftL#` 16#) `iShiftRA#` 16#
#endif
where
#if __GLASGOW_HASKELL__ >= 503
i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
#else
i = word2Int# ((high `shiftL#` 8#) `or#` low)
#endif
high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
low = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 2#
data HappyAddr = HappyA# Addr#
-----------------------------------------------------------------------------
-- HappyState data type (not arrays)
{-# LINE 169 "GenericTemplate.hs" #-}
-----------------------------------------------------------------------------
-- Shifting a token
happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in
-- trace "shifting the error token" $
happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
happyShift new_state i tk st sts stk =
happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)
-- happyReduce is specialised for the common cases.
happySpecReduce_0 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_0 nt fn j tk st@((action)) sts stk
= happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
happySpecReduce_1 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
= let r = fn v1 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_2 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
= let r = fn v1 v2 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_3 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
= let r = fn v1 v2 v3 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happyReduce k i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happyReduce k nt fn j tk st sts stk
= case happyDrop (k -# (1# :: Int#)) sts of
sts1@((HappyCons (st1@(action)) (_))) ->
let r = fn stk in -- it doesn't hurt to always seq here...
happyDoSeq r (happyGoto nt j tk st1 sts1 r)
happyMonadReduce k nt fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happyMonadReduce k nt fn j tk st sts stk =
happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
drop_stk = happyDropStk k stk
happyDrop 0# l = l
happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
happyDropStk 0# l = l
happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
-----------------------------------------------------------------------------
-- Moving to a new state after a reduction
happyGoto nt j tk st =
{- nothing -}
happyDoAction j tk new_state
where off = indexShortOffAddr happyGotoOffsets st
off_i = (off +# nt)
new_state = indexShortOffAddr happyTable off_i
-----------------------------------------------------------------------------
-- Error recovery (0# is the error token)
-- parse error if we are in recovery and we fail again
happyFail 0# tk old_st _ stk =
-- trace "failing" $
happyError_ tk
{- We don't need state discarding for our restricted implementation of
"error". In fact, it can cause some bogus parses, so I've disabled it
for now --SDM
-- discard a state
happyFail 0# tk old_st (HappyCons ((action)) (sts))
(saved_tok `HappyStk` _ `HappyStk` stk) =
-- trace ("discarding state, depth " ++ show (length stk)) $
happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
-}
-- Enter error recovery: generate an error token,
-- save the old token and carry on.
happyFail i tk (action) sts stk =
-- trace "entering error recovery" $
happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)
-- Internal happy errors:
notHappyAtAll = error "Internal Happy error\n"
-----------------------------------------------------------------------------
-- Hack to get the typechecker to accept our action functions
happyTcHack :: Int# -> a -> a
happyTcHack x y = y
{-# INLINE happyTcHack #-}
-----------------------------------------------------------------------------
-- Seq-ing. If the --strict flag is given, then Happy emits
-- happySeq = happyDoSeq
-- otherwise it emits
-- happySeq = happyDontSeq
happyDoSeq, happyDontSeq :: a -> b -> b
happyDoSeq a b = a `seq` b
happyDontSeq a b = b
-----------------------------------------------------------------------------
-- Don't inline any functions from the template. GHC has a nasty habit
-- of deciding to inline happyGoto everywhere, which increases the size of
-- the generated parser quite a bit.
{-# NOINLINE happyDoAction #-}
{-# NOINLINE happyTable #-}
{-# NOINLINE happyCheck #-}
{-# NOINLINE happyActOffsets #-}
{-# NOINLINE happyGotoOffsets #-}
{-# NOINLINE happyDefActions #-}
{-# NOINLINE happyShift #-}
{-# NOINLINE happySpecReduce_0 #-}
{-# NOINLINE happySpecReduce_1 #-}
{-# NOINLINE happySpecReduce_2 #-}
{-# NOINLINE happySpecReduce_3 #-}
{-# NOINLINE happyReduce #-}
{-# NOINLINE happyMonadReduce #-}
{-# NOINLINE happyGoto #-}
{-# NOINLINE happyFail #-}
-- end of Happy Template.

129
src-3.0/GF/CFGM/ParCFG.y
View File

@@ -1,129 +0,0 @@
-- This Happy file was machine-generated by the BNF converter
{
module ParCFG where
import AbsCFG
import LexCFG
import ErrM
}
%name pGrammars Grammars
-- no lexer declaration
%monad { Err } { thenM } { returnM }
%tokentype { Token }
%token
';' { PT _ (TS ";") }
':' { PT _ (TS ":") }
'.' { PT _ (TS ".") }
'->' { PT _ (TS "->") }
'_' { PT _ (TS "_") }
'[' { PT _ (TS "[") }
']' { PT _ (TS "]") }
',' { PT _ (TS ",") }
'end' { PT _ (TS "end") }
'grammar' { PT _ (TS "grammar") }
'startcat' { PT _ (TS "startcat") }
L_ident { PT _ (TV $$) }
L_integ { PT _ (TI $$) }
L_quoted { PT _ (TL $$) }
L_SingleQuoteString { PT _ (T_SingleQuoteString $$) }
L_err { _ }
%%
Ident :: { Ident } : L_ident { Ident $1 }
Integer :: { Integer } : L_integ { (read $1) :: Integer }
String :: { String } : L_quoted { $1 }
SingleQuoteString :: { SingleQuoteString} : L_SingleQuoteString { SingleQuoteString ($1)}
Grammars :: { Grammars }
Grammars : ListGrammar { Grammars (reverse $1) }
Grammar :: { Grammar }
Grammar : 'grammar' Ident ListFlag ListRule 'end' 'grammar' { Grammar $2 (reverse $3) (reverse $4) }
ListGrammar :: { [Grammar] }
ListGrammar : {- empty -} { [] }
| ListGrammar Grammar { flip (:) $1 $2 }
Flag :: { Flag }
Flag : 'startcat' Category { StartCat $2 }
ListFlag :: { [Flag] }
ListFlag : {- empty -} { [] }
| ListFlag Flag ';' { flip (:) $1 $2 }
Rule :: { Rule }
Rule : Fun ':' Profiles '.' Category '->' ListSymbol { Rule $1 $3 $5 $7 }
ListRule :: { [Rule] }
ListRule : {- empty -} { [] }
| ListRule Rule ';' { flip (:) $1 $2 }
Fun :: { Fun }
Fun : Ident { Cons $1 }
| '_' { Coerce }
Profiles :: { Profiles }
Profiles : '[' ListProfile ']' { Profiles $2 }
ListProfile :: { [Profile] }
ListProfile : {- empty -} { [] }
| Profile { (:[]) $1 }
| Profile ',' ListProfile { (:) $1 $3 }
Profile :: { Profile }
Profile : '[' ListInteger ']' { UnifyProfile $2 }
| Ident { ConstProfile $1 }
ListInteger :: { [Integer] }
ListInteger : {- empty -} { [] }
| Integer { (:[]) $1 }
| Integer ',' ListInteger { (:) $1 $3 }
Symbol :: { Symbol }
Symbol : Category { CatS $1 }
| String { TermS $1 }
ListSymbol :: { [Symbol] }
ListSymbol : '.' { [] }
| Symbol { (:[]) $1 }
| Symbol ListSymbol { (:) $1 $2 }
Category :: { Category }
Category : SingleQuoteString { Category $1 }
{
returnM :: a -> Err a
returnM = return
thenM :: Err a -> (a -> Err b) -> Err b
thenM = (>>=)
happyError :: [Token] -> Err a
happyError ts =
Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
myLexer = tokens
}

157
src-3.0/GF/CFGM/PrintCFG.hs
View File

@@ -1,157 +0,0 @@
module GF.CFGM.PrintCFG where
-- pretty-printer generated by the BNF converter
import GF.CFGM.AbsCFG
import Char
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
prtList :: [a] -> Doc
prtList = concatD . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = doc (shows x)
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Double where
prt _ x = doc (shows x)
instance Print Ident where
prt _ (Ident i) = doc (showString i)
instance Print SingleQuoteString where
prt _ (SingleQuoteString i) = doc (showString i)
instance Print Grammars where
prt i e = case e of
Grammars grammars -> prPrec i 0 (concatD [prt 0 grammars])
instance Print Grammar where
prt i e = case e of
Grammar id flags rules -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 id , prt 0 flags , prt 0 rules , doc (showString "end") , doc (showString "grammar")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Flag where
prt i e = case e of
StartCat category -> prPrec i 0 (concatD [doc (showString "startcat") , prt 0 category])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Rule where
prt i e = case e of
Rule fun profiles category symbols -> prPrec i 0 (concatD [prt 0 fun , doc (showString ":") , prt 0 profiles , doc (showString ".") , prt 0 category , doc (showString "->") , prt 0 symbols])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Fun where
prt i e = case e of
Cons id -> prPrec i 0 (concatD [prt 0 id])
Coerce -> prPrec i 0 (concatD [doc (showString "_")])
instance Print Profiles where
prt i e = case e of
Profiles profiles -> prPrec i 0 (concatD [doc (showString "[") , prt 0 profiles , doc (showString "]")])
instance Print Profile where
prt i e = case e of
UnifyProfile ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")])
ConstProfile id -> prPrec i 0 (concatD [prt 0 id])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Symbol where
prt i e = case e of
CatS category -> prPrec i 0 (concatD [prt 0 category])
TermS str -> prPrec i 0 (concatD [prt 0 str])
prtList es = case es of
[] -> (concatD [doc (showString ".")])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Category where
prt i e = case e of
Category singlequotestring -> prPrec i 0 (concatD [prt 0 singlequotestring])

113
src-3.0/GF/CFGM/PrintCFGrammar.hs
View File

@@ -1,113 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PrintCFGrammar
-- Maintainer : BB
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/17 14:04:38 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.20 $
--
-- Handles printing a CFGrammar in CFGM format.
-----------------------------------------------------------------------------
module GF.CFGM.PrintCFGrammar (prCanonAsCFGM) where
import GF.Canon.AbsGFC
import qualified GF.CFGM.PrintCFG as PrintCFG
import GF.Infra.Ident
import GF.Canon.GFC
import GF.Infra.Modules
import qualified GF.Conversion.GFC as Cnv
import GF.Infra.Print (prt)
import GF.Formalism.CFG (CFRule(..))
import qualified GF.Formalism.Utilities as GU
import qualified GF.Conversion.Types as GT
import qualified GF.CFGM.AbsCFG as AbsCFG
import GF.Formalism.Utilities (Symbol(..))
import GF.Data.ErrM
import GF.Data.Utilities (compareBy)
import qualified GF.Infra.Option as Option
import Data.List (intersperse, sortBy)
import Data.Maybe (listToMaybe, maybeToList, maybe)
import GF.Infra.Print
import GF.System.Tracing
-- | FIXME: should add an Options argument,
-- to be able to decide which CFG conversion one wants to use
prCanonAsCFGM :: Option.Options -> CanonGrammar -> String
prCanonAsCFGM opts gr = unlines $ map (prLangAsCFGM gr) xs
where
cncs = maybe [] (allConcretes gr) (greatestAbstract gr)
cncms = map (\i -> (i,fromOk (lookupModule gr i))) cncs
fromOk (Ok x) = x
fromOk (Bad y) = error y
xs = tracePrt "CFGM languages" (prtBefore "\n")
[ (i, getFlag fs "startcat", getFlag fs "conversion") |
(i, ModMod (Module{flags=fs})) <- cncms ]
-- | FIXME: need to look in abstract module too
getFlag :: [Flag] -> String -> Maybe String
getFlag fs x = listToMaybe [v | Flg (IC k) (IC v) <- fs, k == x]
-- FIXME: (1) Should use 'ShellState.stateCFG'
-- instead of 'Cnv.gfc2cfg' (which recalculates the grammar every time)
--
-- FIXME: (2) Should use the state options, when calculating the CFG
-- (this is solved automatically if one solves (1) above)
prLangAsCFGM :: CanonGrammar -> (Ident, Maybe String, Maybe String) -> String
prLangAsCFGM gr (i, start, cnv) = prCFGrammarAsCFGM (Cnv.gfc2cfg opts (gr, i)) i start
-- prLangAsCFGM gr i start = prCFGrammarAsCFGM (Cnv.cfg (Cnv.pInfo opts gr i)) i start
where opts = Option.Opts $ maybeToList $ fmap Option.gfcConversion cnv
prCFGrammarAsCFGM :: GT.CGrammar -> Ident -> Maybe String -> String
prCFGrammarAsCFGM gr i start = PrintCFG.printTree $ cfGrammarToCFGM gr i start
cfGrammarToCFGM :: GT.CGrammar -> Ident -> Maybe String -> AbsCFG.Grammar
cfGrammarToCFGM gr i start =
AbsCFG.Grammar (identToCFGMIdent i) flags $ sortCFGMRules $ map ruleToCFGMRule gr
where flags = maybe [] (\c -> [AbsCFG.StartCat $ strToCFGMCat (c++"{}.s")]) start
sortCFGMRules = sortBy (compareBy ruleKey)
ruleKey (AbsCFG.Rule f ps cat rhs) = (cat,f)
ruleToCFGMRule :: GT.CRule -> AbsCFG.Rule
ruleToCFGMRule (CFRule c rhs (GU.Name fun profile))
= AbsCFG.Rule fun' p' c' rhs'
where
fun' = identToFun fun
p' = profileToCFGMProfile profile
c' = catToCFGMCat c
rhs' = map symbolToGFCMSymbol rhs
profileToCFGMProfile :: [GU.Profile (GU.SyntaxForest GT.Fun)] -> AbsCFG.Profiles
profileToCFGMProfile = AbsCFG.Profiles . map cnvProfile
where cnvProfile (GU.Unify ns) = AbsCFG.UnifyProfile $ map fromIntegral ns
-- FIXME: is it always FNode?
cnvProfile (GU.Constant (GU.FNode c _)) = AbsCFG.ConstProfile $ identToCFGMIdent c
identToCFGMIdent :: Ident -> AbsCFG.Ident
identToCFGMIdent = AbsCFG.Ident . prt
identToFun :: Ident -> AbsCFG.Fun
identToFun IW = AbsCFG.Coerce
identToFun i = AbsCFG.Cons (identToCFGMIdent i)
strToCFGMCat :: String -> AbsCFG.Category
strToCFGMCat = AbsCFG.Category . AbsCFG.SingleQuoteString . quoteSingle
catToCFGMCat :: GT.CCat -> AbsCFG.Category
catToCFGMCat = strToCFGMCat . prt
symbolToGFCMSymbol :: Symbol GT.CCat GT.Token -> AbsCFG.Symbol
symbolToGFCMSymbol (Cat c) = AbsCFG.CatS (catToCFGMCat c)
symbolToGFCMSymbol (Tok t) = AbsCFG.TermS (prt t)
quoteSingle :: String -> String
quoteSingle s = "'" ++ escapeSingle s ++ "'"
where escapeSingle = concatMap (\c -> if c == '\'' then "\\'" else [c])

182
src-3.0/GF/Canon/AbsGFC.hs
View File

@@ -1,182 +0,0 @@
module GF.Canon.AbsGFC where
import GF.Infra.Ident --H
-- Haskell module generated by the BNF converter, except --H
-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
data Canon =
MGr [Ident] Ident [Module]
| Gr [Module]
deriving (Eq,Ord,Show)
data Line =
LMulti [Ident] Ident
| LHeader ModType Extend Open
| LFlag Flag
| LDef Def
| LEnd
deriving (Eq,Ord,Show)
data Module =
Mod ModType Extend Open [Flag] [Def]
deriving (Eq,Ord,Show)
data ModType =
MTAbs Ident
| MTCnc Ident Ident
| MTRes Ident
| MTTrans Ident Ident Ident
deriving (Eq,Ord,Show)
data Extend =
Ext [Ident]
| NoExt
deriving (Eq,Ord,Show)
data Open =
Opens [Ident]
| NoOpens
deriving (Eq,Ord,Show)
data Flag =
Flg Ident Ident
deriving (Eq,Ord,Show)
data Def =
AbsDCat Ident [Decl] [CIdent]
| AbsDFun Ident Exp Exp
| AbsDTrans Ident Exp
| ResDPar Ident [ParDef]
| ResDOper Ident CType Term
| CncDCat Ident CType Term Term
| CncDFun Ident CIdent [ArgVar] Term Term
| AnyDInd Ident Status Ident
deriving (Eq,Ord,Show)
data ParDef =
ParD Ident [CType]
deriving (Eq,Ord,Show)
data Status =
Canon
| NonCan
deriving (Eq,Ord,Show)
data CIdent =
CIQ Ident Ident
deriving (Eq,Ord,Show)
data Exp =
EApp Exp Exp
| EProd Ident Exp Exp
| EAbs Ident Exp
| EAtom Atom
| EData
| EEq [Equation]
deriving (Eq,Ord,Show)
data Sort =
SType
deriving (Eq,Ord,Show)
data Equation =
Equ [APatt] Exp
deriving (Eq,Ord,Show)
data APatt =
APC CIdent [APatt]
| APV Ident
| APS String
| API Integer
| APF Double
| APW
deriving (Eq,Ord,Show)
data Atom =
AC CIdent
| AD CIdent
| AV Ident
| AM Integer
| AS String
| AI Integer
| AF Double
| AT Sort
deriving (Eq,Ord,Show)
data Decl =
Decl Ident Exp
deriving (Eq,Ord,Show)
data CType =
RecType [Labelling]
| Table CType CType
| Cn CIdent
| TStr
| TInts Integer
deriving (Eq,Ord,Show)
data Labelling =
Lbg Label CType
deriving (Eq,Ord,Show)
data Term =
Arg ArgVar
| I CIdent
| Par CIdent [Term]
| LI Ident
| R [Assign]
| P Term Label
| T CType [Case]
| V CType [Term]
| S Term Term
| C Term Term
| FV [Term]
| EInt Integer
| EFloat Double
| K Tokn
| E
deriving (Eq,Ord,Show)
data Tokn =
KS String
| KP [String] [Variant]
| KM String
deriving (Eq,Ord,Show)
data Assign =
Ass Label Term
deriving (Eq,Ord,Show)
data Case =
Cas [Patt] Term
deriving (Eq,Ord,Show)
data Variant =
Var [String] [String]
deriving (Eq,Ord,Show)
data Label =
L Ident
| LV Integer
deriving (Eq,Ord,Show)
data ArgVar =
A Ident Integer
| AB Ident Integer Integer
deriving (Eq,Ord,Show)
data Patt =
PC CIdent [Patt]
| PV Ident
| PW
| PR [PattAssign]
| PI Integer
| PF Double
deriving (Eq,Ord,Show)
data PattAssign =
PAss Label Patt
deriving (Eq,Ord,Show)

38
src-3.0/GF/Canon/AbsToBNF.hs
View File

@@ -1,38 +0,0 @@
module GF.Canon.AbsToBNF where
import GF.Grammar.SGrammar
import GF.Data.Operations
import GF.Infra.Option
import GF.Canon.GFC (CanonGrammar)
-- AR 10/5/2007
abstract2bnf :: CanonGrammar -> String
abstract2bnf = sgrammar2bnf . gr2sgr noOptions emptyProbs
sgrammar2bnf :: SGrammar -> String
sgrammar2bnf = unlines . map (prBNFRule . mkBNF) . allRules
prBNFRule :: BNFRule -> String
prBNFRule = id
type BNFRule = String
mkBNF :: SRule -> BNFRule
mkBNF (pfun,(args,cat)) =
fun ++ "." +++ gfId cat +++ "::=" +++ rhs +++ ";"
where
fun = gfId (snd pfun)
rhs = case args of
[] -> prQuotedString (snd pfun)
_ -> unwords (map gfId args)
-- good for GF
gfId i = i
-- good for BNFC
gfIdd i = case i of
"Int" -> "Integer"
"String" -> i
"Float" -> "Double"
_ -> "G" ++ i ++ "_"

334
src-3.0/GF/Canon/CMacros.hs
View File

@@ -1,334 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CMacros
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:41 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.29 $
--
-- 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 GF.Canon.CMacros where
import GF.Infra.Ident
import GF.Canon.AbsGFC
import GF.Canon.GFC
import qualified GF.Infra.Ident as A ---- no need to qualif? 21/9
import qualified GF.Grammar.Values as V
import qualified GF.Grammar.MMacros as M
import GF.Grammar.PrGrammar
import GF.Data.Str
import GF.Data.Operations
import Data.Char
import Control.Monad
-- | how to mark subtrees, dep. on node, position, whether focus
type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String)
-- | also to process the text (needed for escapes e.g. in XML)
type Marker = (JustMarker, Maybe (String -> String))
defTMarker :: JustMarker -> Marker
defTMarker = flip (curry id) Nothing
markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term
markSubtree (mk,esc) n is = markSubterm esc . mk n is
escapeMkString :: Marker -> Maybe (String -> String)
escapeMkString = snd
-- | if no marking is wanted, use the following
noMark :: Marker
noMark = defTMarker mk where
mk _ _ _ = ("","")
-- | mark metas with their categories
metaCatMark :: Marker
metaCatMark = defTMarker mk where
mk nod _ _ = case nod of
V.N (_,V.AtM _,val,_,_) -> ("", '+':prt val)
_ -> ("","")
-- | for vanilla brackets, focus, and position, use
markBracket :: Marker
markBracket = defTMarker mk where
mk n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
-- | for focus only
markFocus :: Marker
markFocus = defTMarker mk where
mk n p b = if b then ("[*","*]") else ("","")
-- | for XML, use
markJustXML :: JustMarker
markJustXML n i b =
if b
then ("<focus" +++ p +++ c ++ s ++ ">", "</focus>")
else ("<subtree" +++ p +++ c ++ s ++ ">", "</subtree>")
where
c = "type=" ++ prt (M.valNode n)
p = "position=" ++ (show $ reverse i)
s = if (null (M.constrsNode n)) then "" else " status=incorrect"
markXML :: Marker
markXML = (markJustXML, Just esc) where
esc s = case s of
'\\':'<':cs -> '\\':'<':esc cs
'\\':'>':cs -> '\\':'>':esc cs
'\\':'\\':cs -> '\\':'\\':esc cs
----- the first 3 needed because marking may revisit; needs to be fixed
'<':cs -> '\\':'<':esc cs
'>':cs -> '\\':'>':esc cs
'\\':cs -> '\\':'\\':esc cs
c :cs -> c :esc cs
_ -> s
-- | for XML in JGF 1, use
markXMLjgf :: Marker
markXMLjgf = defTMarker mk where
mk n p b =
if b
then ("<focus" +++ c ++ ">", "</focus>")
else ("","")
where
c = "type=" ++ prt (M.valNode n)
-- | the marking engine
markSubterm :: Maybe (String -> String) -> (String,String) -> Term -> Term
markSubterm esc (beg, end) t = case t of
R rs -> R $ map markField rs
T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
FV ts -> FV $ map mark ts
_ -> foldr1 C (tm beg ++ [mkEscIf t] ++ tm end) -- t : Str guaranteed?
where
mark = markSubterm esc (beg, end)
markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
tm s = if null s then [] else [tM s]
mkEscIf t = case esc of
Just f -> mkEsc f t
_ -> t
mkEsc f t = case t of
K (KS s) -> K (KS (f s))
C u v -> C (mkEsc f u) (mkEsc f v)
FV ts -> FV (map (mkEsc f) ts)
_ -> t ---- do we need to look at other cases?
tK,tM :: String -> Term
tK = K . KS
tM = K . KM
term2patt :: Term -> Err Patt
term2patt trm = case trm of
Par c aa -> do
aa' <- mapM term2patt aa
return (PC c aa')
R r -> do
let (ll,aa) = unzip [(l,a) | Ass l a <- r]
aa' <- mapM term2patt aa
return (PR (map (uncurry PAss) (zip ll aa')))
LI x -> return $ PV x
EInt i -> return $ PI i
EFloat i -> return $ PF i
FV (t:_) -> term2patt t ----
_ -> prtBad "no pattern corresponds to term" trm
patt2term :: Patt -> Term
patt2term p = case p of
PC x ps -> Par x (map patt2term ps)
PV x -> LI x
PW -> anyTerm ----
PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ]
PI i -> EInt i
PF i -> EFloat i
anyTerm :: Term
anyTerm = LI (A.identC "_") --- should not happen
matchPatt :: [Case] -> Term -> Err Term
matchPatt cs0 (FV ts) = liftM FV $ mapM (matchPatt cs0) ts
matchPatt cs0 trm = term2patt trm >>= match cs0 where
match cs t =
case cs of
Cas ps b :_ | elem t ps -> return b
_:cs' -> match cs' t
[] -> Bad $ "pattern not found for" +++ prt t
+++ "among" ++++ unlines (map prt cs0) ---- debug
defLinType :: CType
defLinType = RecType [Lbg (L (A.identC "s")) TStr]
defLindef :: Term
defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))]
isDiscontinuousCType :: CType -> Bool
isDiscontinuousCType t = case t of
RecType rs -> length [t | Lbg _ t <- rs, valTableType t == TStr] > 1
_ -> True --- does not occur; would not behave well in lin commands
valTableType :: CType -> CType
valTableType t = case t of
Table _ v -> valTableType v
_ -> t
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case t of
K (KS s) -> return [str s]
K (KM s) -> return [str s]
K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]]
C s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [plusStr x y | x <- s', y <- t']
FV ts -> liftM concat $ mapM strsFromTerm ts
E -> return [str []]
_ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug
---- _ -> prtBad "cannot get Str from term " t
-- | recursively collect all branches in a table
allInTable :: Term -> [Term]
allInTable t = case t of
T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ?
_ -> [t]
-- | to gather s-fields; assumes term in normal form, preserves label
allLinFields :: Term -> Err [[(Label,Term)]]
allLinFields trm = case trm of
---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad
FV ts -> do
lts <- mapM allLinFields ts
return $ concat lts
T _ ts -> liftM concat $ mapM allLinFields [t | Cas _ t <- ts]
V _ ts -> liftM concat $ mapM allLinFields ts
S t _ -> allLinFields t
_ -> prtBad "fields can only be sought in a record not in" trm
-- | deprecated
isLinLabel :: Label -> Bool
isLinLabel l = case l of
L (A.IC ('s':cs)) | all isDigit cs -> True
-- peb (28/4-04), for MCFG grammars to work:
L (A.IC cs) | null cs || head cs `elem` ".!" -> True
_ -> False
-- | to gather ultimate cases in a table; preserves pattern list
allCaseValues :: Term -> [([Patt],Term)]
allCaseValues trm = case trm of
T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0]
_ -> [([],trm)]
-- | 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 gather all fields; does not assume s naming of fields;
-- used in Morpho only
allAllLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
allAllLinValues trm = do
lts <- allFields trm
mapM (mapPairsM (return . allCaseValues)) lts
where
allFields trm = case trm of
R rs -> return [[(l,t) | Ass l t <- rs]]
FV ts -> do
lts <- mapM allFields ts
return $ concat lts
_ -> prtBad "fields can only be sought in a record not in" trm
-- | to gather all linearizations, even from nested records; params ignored
allLinBranches :: Term -> [([Label],Term)]
allLinBranches trm = case trm of
R rs -> [(l:ls,u) | Ass l t <- rs, (ls,u) <- allLinBranches t]
FV ts -> concatMap allLinBranches ts
T _ ts -> concatMap allLinBranches [t | Cas _ t <- ts]
V _ ts -> concatMap allLinBranches ts
_ -> [([],trm)]
redirectIdent :: A.Ident -> CIdent -> CIdent
redirectIdent n f@(CIQ _ c) = CIQ n c
ciq :: A.Ident -> A.Ident -> CIdent
ciq n f = CIQ n f
wordsInTerm :: Term -> [String]
wordsInTerm trm = filter (not . null) $ case trm of
K (KS s) -> [s]
S c _ -> wo c
R rs -> concat [wo t | Ass _ t <- rs]
T _ cs -> concat [wo t | Cas _ t <- cs]
V _ cs -> concat [wo t | t <- cs]
C s t -> wo s ++ wo t
FV ts -> concatMap wo ts
K (KP ss vs) -> ss ++ concat [s | Var s _ <- vs]
P t _ -> wo t --- not needed ?
_ -> []
where wo = wordsInTerm
onTokens :: (String -> String) -> Term -> Term
onTokens f t = case t of
K (KS s) -> K (KS (f s))
K (KP ss vs) -> K (KP (map f ss) [Var (map f x) (map f y) | Var x y <- vs])
_ -> composSafeOp (onTokens f) t
-- | to define compositional term functions
composSafeOp :: (Term -> Term) -> Term -> Term
composSafeOp op trm = case composOp (mkMonadic op) trm of
Ok t -> t
_ -> error "the operation is safe isn't it ?"
where
mkMonadic f = return . f
-- | to define compositional term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm =
case trm of
Par x as ->
do
as' <- mapM co as
return (Par x as')
R as ->
do
let onAss (Ass l t) = liftM (Ass l) (co t)
as' <- mapM onAss as
return (R as')
P a x ->
do
a' <- co a
return (P a' x)
T x as ->
do
let onCas (Cas ps t) = liftM (Cas ps) (co t)
as' <- mapM onCas as
return (T x as')
S a b ->
do
a' <- co a
b' <- co b
return (S a' b')
C a b ->
do
a' <- co a
b' <- co b
return (C a' b')
FV as ->
do
as' <- mapM co as
return (FV as')
V x as ->
do
as' <- mapM co as
return (V x as')
_ -> return trm -- covers Arg, I, LI, K, E

45
src-3.0/GF/Canon/CanonToGFCC.hs
View File

@@ -1,45 +0,0 @@
module GF.Canon.CanonToGFCC where
import GF.Devel.GrammarToGFCC
import GF.Devel.PrintGFCC
import GF.GFCC.CheckGFCC (checkGFCCmaybe)
import GF.GFCC.OptimizeGFCC
import GF.Canon.AbsGFC
import GF.Canon.GFC
import GF.Canon.CanonToGrammar
import GF.Canon.Subexpressions
import GF.Devel.PrintGFCC
import GF.Grammar.PrGrammar
import qualified GF.Infra.Modules as M
import GF.Infra.Option
import GF.Data.Operations
import GF.Text.UTF8
canon2gfccPr opts = printGFCC . canon2gfcc opts
canon2gfcc opts = source2gfcc opts . canon2source ----
canon2source = err error id . canon2sourceGrammar . unSubelimCanon
source2gfcc opts gf =
let
(abs,gfcc) = mkCanon2gfcc opts (gfcabs gf) gf
gfcc1 = maybe undefined id $ checkGFCCmaybe gfcc
in addParsers $ if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1
gfcabs gfc =
prt $ head $ M.allConcretes gfc $ maybe (error "no abstract") id $
M.greatestAbstract gfc
{-
-- this variant makes utf8 conversion; used in back ends
mkCanon2gfcc :: CanonGrammar -> D.GFCC
mkCanon2gfcc =
-- canon2gfcc . reorder abs . utf8Conv . canon2canon abs
optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize
-- this variant makes no utf8 conversion; used in ShellState
mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC
mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize
-}

203
src-3.0/GF/Canon/CanonToGrammar.hs
View File

@@ -1,203 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : CanonToGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 14:15:17 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.15 $
--
-- a decompiler. AR 12/6/2003 -- 19/4/2004
-----------------------------------------------------------------------------
module GF.Canon.CanonToGrammar (canon2sourceGrammar, canon2sourceModule, redFlag) where
import GF.Canon.AbsGFC
import GF.Canon.GFC
import GF.Canon.MkGFC
---import CMacros
import qualified GF.Infra.Modules as M
import qualified GF.Infra.Option as O
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.Macros as F
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
canon2sourceGrammar :: CanonGrammar -> Err G.SourceGrammar
canon2sourceGrammar gr = do
ms' <- mapM canon2sourceModule $ M.modules gr
return $ M.MGrammar ms'
canon2sourceModule :: CanonModule -> Err G.SourceModule
canon2sourceModule (i,mi) = do
i' <- redIdent i
info' <- case mi of
M.ModMod m -> do
(e,os) <- redExtOpen m
flags <- mapM redFlag $ M.flags m
(abstr,mt) <- case M.mtype m of
M.MTConcrete a -> do
a' <- redIdent a
return (a', M.MTConcrete a')
M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
M.MTResource -> return (i',M.MTResource) --- c' not needed
M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed
defs <- mapMTree redInfo $ M.jments m
return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs
_ -> Bad $ "cannot decompile module type"
return (i',info')
where
redExtOpen m = do
e' <- return $ M.extend m
os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $
M.opens m
return (e',os')
redInfo :: (Ident,Info) -> Err (Ident,G.Info)
redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
c' <- redIdent c
info' <- case info of
AbsCat cont fs -> do
return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs))
AbsFun typ df -> do
return $ G.AbsFun (Yes typ) (Yes df)
AbsTrans t -> do
return $ G.AbsTrans t
ResPar par -> do
par' <- mapM redParam par
return $ G.ResParam (Yes (par',Nothing)) ---- list of values
ResOper pty ptr -> do
ty' <- redCType pty
trm' <- redCTerm ptr
return $ G.ResOper (Yes ty') (Yes trm')
CncCat pty ptr ppr -> do
ty' <- redCType pty
trm' <- redCTerm ptr
ppr' <- redCTerm ppr
return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr')
CncFun (CIQ abstr cat) xx body ppr -> do
xx' <- mapM redArgVar xx
body' <- redCTerm body
ppr' <- redCTerm ppr
cat' <- redIdent cat
return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing
(Yes (F.mkAbs xx' body')) (Yes ppr')
AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
return (c',info')
redQIdent :: CIdent -> Err G.QIdent
redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c)
redIdent :: Ident -> Err Ident
redIdent = return
redFlag :: Flag -> Err O.Option
redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x])
redDecl :: Decl -> Err G.Decl
redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a)
redType :: Exp -> Err G.Type
redType = redTerm
redTerm :: Exp -> Err G.Term
redTerm t = return $ trExp t
-- resource
redParam (ParD c cont) = do
c' <- redIdent c
cont' <- mapM redCType cont
return $ (c', [(IW,t) | t <- cont'])
-- concrete syntax
redCType :: CType -> Err G.Type
redCType t = case t of
RecType lbs -> do
let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs]
ls' = map redLabel ls
ts' <- mapM redCType ts
return $ G.RecType $ zip ls' ts'
Table p v -> liftM2 G.Table (redCType p) (redCType v)
Cn mc -> liftM (uncurry G.QC) $ redQIdent mc
TStr -> return $ F.typeStr
TInts i -> return $ F.typeInts (fromInteger i)
redCTerm :: Term -> Err G.Term
redCTerm x = case x of
Arg argvar -> liftM G.Vr $ redArgVar argvar
I cident -> liftM (uncurry G.Q) $ redQIdent cident
Par cident terms -> liftM2 F.mkApp
(liftM (uncurry G.QC) $ redQIdent cident)
(mapM redCTerm terms)
LI id -> liftM G.Vr $ redIdent id
R assigns -> do
let (ls,ts) = unzip [(l,t) | Ass l t <- assigns]
let ls' = map redLabel ls
ts' <- mapM redCTerm ts
return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts']
P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label)
T ctype cases -> do
ctype' <- redCType ctype
let (ps,ts) = unzip [(p,t) | Cas [p] t <- cases]
ps' <- mapM redPatt ps
ts' <- mapM redCTerm ts
let tinfo = case ps' of
[G.PV _] -> G.TTyped ctype'
_ -> G.TComp ctype'
return $ G.T tinfo $ zip ps' ts'
V ctype ts -> do
ctype' <- redCType ctype
ts' <- mapM redCTerm ts
return $ G.V ctype' ts'
S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term)
C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term)
FV terms -> liftM G.FV $ mapM redCTerm terms
K (KS str) -> return $ G.K str
EInt i -> return $ G.EInt i
EFloat i -> return $ G.EFloat i
E -> return $ G.Empty
K (KP d vs) -> return $
G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
where
tList ss = case ss of --- this should be in Macros
[] -> G.Empty
_ -> foldr1 G.C $ map G.K ss
failure x = Bad $ "not yet" +++ show x ----
redArgVar :: ArgVar -> Err Ident
redArgVar x = case x of
A x i -> return $ IA (prIdent x, fromInteger i)
AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i)
redLabel :: Label -> G.Label
redLabel (L x) = G.LIdent $ prIdent x
redLabel (LV i) = G.LVar $ fromInteger i
redPatt :: Patt -> Err G.Patt
redPatt p = case p of
PV x -> liftM G.PV $ redIdent x
PC mc ps -> do
(m,c) <- redQIdent mc
liftM (G.PP m c) (mapM redPatt ps)
PR rs -> do
let (ls,ts) = unzip [(l,t) | PAss l t <- rs]
ls' = map redLabel ls
ts <- mapM redPatt ts
return $ G.PR $ zip ls' ts
PI i -> return $ G.PInt i
PF i -> return $ G.PFloat i
_ -> Bad $ "cannot recompile pattern" +++ show p

170
src-3.0/GF/Canon/GFC.cf
View File

@@ -1,170 +0,0 @@
-- top-level grammar
-- Canonical GF. AR 27/4/2003
entrypoints Canon, Line ;
-- old approach: read in a whole grammar
MGr. Canon ::= "grammar" [Ident] "of" Ident ";" [Module] ;
Gr. Canon ::= [Module] ;
-- new approach: read line by line
LMulti. Line ::= "grammar" [Ident] "of" Ident ";" ;
LHeader. Line ::= ModType "=" Extend Open "{" ;
LFlag. Line ::= Flag ";" ;
LDef. Line ::= Def ";" ;
LEnd. Line ::= "}" ;
Mod. Module ::= ModType "=" Extend Open "{" [Flag] [Def] "}" ;
MTAbs. ModType ::= "abstract" Ident ;
MTCnc. ModType ::= "concrete" Ident "of" Ident ;
MTRes. ModType ::= "resource" Ident ;
MTTrans. ModType ::= "transfer" Ident ":" Ident "->" Ident ;
separator Module "" ;
Ext. Extend ::= [Ident] "**" ;
NoExt. Extend ::= ;
Opens. Open ::= "open" [Ident] "in" ;
NoOpens. Open ::= ;
-- judgements
Flg. Flag ::= "flags" Ident "=" Ident ; --- to have the same res word as in GF
AbsDCat. Def ::= "cat" Ident "[" [Decl] "]" "=" [CIdent] ;
AbsDFun. Def ::= "fun" Ident ":" Exp "=" Exp ;
AbsDTrans. Def ::= "transfer" Ident "=" Exp ;
ResDPar. Def ::= "param" Ident "=" [ParDef] ;
ResDOper. Def ::= "oper" Ident ":" CType "=" Term ;
CncDCat. Def ::= "lincat" Ident "=" CType "=" Term ";" Term ;
CncDFun. Def ::= "lin" Ident ":" CIdent "=" "\\" [ArgVar] "->" Term ";" Term ;
AnyDInd. Def ::= Ident Status "in" Ident ;
ParD. ParDef ::= Ident [CType] ;
-- the canonicity of an indirected constant
Canon. Status ::= "data" ;
NonCan. Status ::= ;
-- names originating from resource modules: prefixed by the module name
CIQ. CIdent ::= Ident "." Ident ;
-- types and terms in abstract syntax; no longer type-annotated
EApp. Exp1 ::= Exp1 Exp2 ;
EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ;
EAbs. Exp ::= "\\" Ident "->" Exp ;
EAtom. Exp2 ::= Atom ;
EData. Exp2 ::= "data" ;
EEq. Exp ::= "{" [Equation] "}" ; -- list of pattern eqs; primitive notion: []
coercions Exp 2 ;
SType. Sort ::= "Type" ;
Equ. Equation ::= [APatt] "->" Exp ;
APC. APatt ::= "(" CIdent [APatt] ")" ;
APV. APatt ::= Ident ;
APS. APatt ::= String ;
API. APatt ::= Integer ;
APF. APatt ::= Double ;
APW. APatt ::= "_" ;
separator Decl ";" ;
terminator APatt "" ;
terminator Equation ";" ;
AC. Atom ::= CIdent ;
AD. Atom ::= "<" CIdent ">" ;
AV. Atom ::= "$" Ident ;
AM. Atom ::= "?" Integer ;
AS. Atom ::= String ;
AI. Atom ::= Integer ;
AT. Atom ::= Sort ;
Decl. Decl ::= Ident ":" Exp ;
-- types, terms, and patterns in concrete syntax
RecType. CType ::= "{" [Labelling] "}" ;
Table. CType ::= "(" CType "=>" CType ")" ;
Cn. CType ::= CIdent ;
TStr. CType ::= "Str" ;
TInts. CType ::= "Ints" Integer ;
Lbg. Labelling ::= Label ":" CType ;
Arg. Term2 ::= ArgVar ;
I. Term2 ::= CIdent ; -- from resources
Par. Term2 ::= "<" CIdent [Term2] ">" ;
LI. Term2 ::= "$" Ident ; -- from pattern variables
R. Term2 ::= "{" [Assign] "}" ;
P. Term1 ::= Term2 "." Label ;
T. Term1 ::= "table" CType "{" [Case] "}" ;
V. Term1 ::= "table" CType "[" [Term2] "]" ;
S. Term1 ::= Term1 "!" Term2 ;
C. Term ::= Term "++" Term1 ;
FV. Term1 ::= "variants" "{" [Term2] "}" ; --- no separator!
EInt. Term2 ::= Integer ;
EFloat. Term2 ::= Double ;
K. Term2 ::= Tokn ;
E. Term2 ::= "[" "]" ;
KS. Tokn ::= String ;
KP. Tokn ::= "[" "pre" [String] "{" [Variant] "}" "]" ;
internal KM. Tokn ::= String ; -- mark-up
Ass. Assign ::= Label "=" Term ;
Cas. Case ::= [Patt] "=>" Term ;
Var. Variant ::= [String] "/" [String] ;
coercions Term 2 ;
L. Label ::= Ident ;
LV. Label ::= "$" Integer ;
A. ArgVar ::= Ident "@" Integer ; -- no bindings
AB. ArgVar ::= Ident "+" Integer "@" Integer ; -- with a number of bindings
PC. Patt ::= "(" CIdent [Patt] ")" ;
PV. Patt ::= Ident ;
PW. Patt ::= "_" ;
PR. Patt ::= "{" [PattAssign] "}" ;
PI. Patt ::= Integer ;
PF. Patt ::= Double ;
PAss. PattAssign ::= Label "=" Patt ;
--- here we use the new pragmas to generate list rules
terminator Flag ";" ;
terminator Def ";" ;
separator ParDef "|" ;
separator CType "" ;
separator CIdent "" ;
separator Assign ";" ;
separator ArgVar "," ;
separator Labelling ";" ;
separator Case ";" ;
separator Term2 "" ;
separator String "" ;
separator Variant ";" ;
separator PattAssign ";" ;
separator Patt "" ;
separator Ident "," ;

104
src-3.0/GF/Canon/GFC.hs
View File

@@ -1,104 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GFC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:22 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.12 $
--
-- canonical GF. AR 10\/9\/2002 -- 9\/5\/2003 -- 21\/9
-----------------------------------------------------------------------------
module GF.Canon.GFC (Context,
CanonGrammar,
CanonModInfo,
CanonModule,
CanonAbs,
Info(..),
Printname,
prPrintnamesGrammar,
mapInfoTerms,
setFlag,
flagIncomplete,
isIncompleteCanon,
hasFlagCanon,
flagCanon
) where
import GF.Canon.AbsGFC
import GF.Canon.PrintGFC
import qualified GF.Grammar.Abstract as A
import GF.Infra.Ident
import GF.Infra.Option
import GF.Data.Zipper
import GF.Data.Operations
import qualified GF.Infra.Modules as M
import Data.Char
import qualified Data.ByteString.Char8 as BS
import Control.Arrow (first)
type Context = [(Ident,Exp)]
type CanonGrammar = M.MGrammar Ident Flag Info
type CanonModInfo = M.ModInfo Ident Flag Info
type CanonModule = (Ident, CanonModInfo)
type CanonAbs = M.Module Ident Option Info
data Info =
AbsCat A.Context [A.Fun]
| AbsFun A.Type A.Term
| AbsTrans A.Term
| ResPar [ParDef]
| ResOper CType Term -- ^ global constant
| CncCat CType Term Printname
| CncFun CIdent [ArgVar] Term Printname
| AnyInd Bool Ident
deriving (Show)
type Printname = Term
mapInfoTerms :: (Term -> Term) -> Info -> Info
mapInfoTerms f i = case i of
ResOper x a -> ResOper x (f a)
CncCat x a y -> CncCat x (f a) y
CncFun x y a z -> CncFun x y (f a) z
_ -> i
setFlag :: String -> String -> [Flag] -> [Flag]
setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= BS.pack n]
flagIncomplete :: Flag
flagIncomplete = flagCanon "incomplete" "true"
isIncompleteCanon :: CanonModule -> Bool
isIncompleteCanon = hasFlagCanon flagIncomplete
hasFlagCanon :: Flag -> CanonModule -> Bool
hasFlagCanon f (_,M.ModMod mo) = elem f $ M.flags mo
hasFlagCanon f _ = True ---- safe, useless
flagCanon :: String -> String -> Flag
flagCanon f v = Flg (identC (BS.pack f)) (identC (BS.pack v))
-- for Ha-Jo 20/2/2005
prPrintnamesGrammar :: CanonGrammar -> String
prPrintnamesGrammar gr = unlines $ filter (not . null) [prPrint j |
(_,M.ModMod m) <- M.modules gr,
M.isModCnc m,
j <- tree2list $ M.jments m
]
where
prPrint j = case j of
(c,CncCat _ _ p) -> "printname cat" +++ A.prt_ c +++ "=" +++ A.prt_ p
(c,CncFun _ _ _ p) -> "printname fun" +++ A.prt_ c +++ "=" +++ A.prt_ p
_ -> []

78
src-3.0/GF/Canon/GetGFC.hs
View File

@@ -1,78 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GetGFC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:43 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.9 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Canon.GetGFC (getCanonModule, getCanonGrammar) where
import GF.Data.Operations
import GF.Canon.ParGFC
import GF.Canon.GFC
import GF.Canon.MkGFC
import GF.Infra.Modules
import GF.Infra.UseIO
import System.IO
import System.Directory
import Control.Monad
getCanonModule :: FilePath -> IOE CanonModule
getCanonModule file = do
gr <- getCanonGrammar file
case modules gr of
[m] -> return m
_ -> ioeErr $ Bad "expected exactly one module in a file"
getCanonGrammar :: FilePath -> IOE CanonGrammar
-- getCanonGrammar = getCanonGrammarByLine
getCanonGrammar file = do
s <- ioeIO $ readFileIf file
c <- ioeErr $ pCanon $ myLexer s
return $ canon2grammar c
{-
-- the following surprisingly does not save memory so it is
-- not in use
getCanonGrammarByLine :: FilePath -> IOE CanonGrammar
getCanonGrammarByLine file = do
b <- ioeIO $ doesFileExist file
if not b
then ioeErr $ Bad $ "file" +++ file +++ "does not exist"
else do
ioeIO $ putStrLn ""
hand <- ioeIO $ openFile file ReadMode ---- err
size <- ioeIO $ hFileSize hand
gr <- addNextLine (size,0) 1 hand emptyMGrammar
ioeIO $ hClose hand
return $ MGrammar $ reverse $ modules gr
where
addNextLine (size,act) d hand gr = do
eof <- ioeIO $ hIsEOF hand
if eof
then return gr
else do
s <- ioeIO $ hGetLine hand
let act' = act + toInteger (length s)
-- if isHash act act' then (ioeIO $ putChar '#') else return ()
updGrammar act' d gr $ pLine $ myLexer s
where
updGrammar a d gr (Ok t) = case buildCanonGrammar d gr t of
(gr',d') -> addNextLine (size,a) d' hand gr'
updGrammar _ _ gr (Bad s) = do
ioeIO $ putStrLn s
return emptyMGrammar
isHash a b = a `div` step < b `div` step
step = size `div` 50
-}

346
src-3.0/GF/Canon/LexGFC.hs
View File

@@ -1,346 +0,0 @@
{-# OPTIONS -fglasgow-exts -cpp #-}
{-# LINE 3 "LexGFC.x" #-}
module GF.Canon.LexGFC where --H
import GF.Data.ErrM --H
import GF.Data.SharedString --H
#if __GLASGOW_HASKELL__ >= 603
#include "ghcconfig.h"
#else
#include "config.h"
#endif
#if __GLASGOW_HASKELL__ >= 503
import Data.Array
import Data.Char (ord)
import Data.Array.Base (unsafeAt)
#else
import Array
import Char (ord)
#endif
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts
#else
import GlaExts
#endif
alex_base :: AlexAddr
alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x1d\x00\x00\x00\x0b\x00\x00\x00\x20\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\x6d\x01\x00\x00"#
alex_table :: AlexAddr
alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x0a\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\x07\x00\x05\x00\x03\x00\x06\x00\x03\x00\x03\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x03\x00\x03\x00\x04\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\x02\x00\x0f\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0a\x00\x00\x00\x00\x00\xff\xff\x08\x00\x0a\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0b\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x10\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
alex_check :: AlexAddr
alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\x2b\x00\x3e\x00\x2a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
alex_deflt :: AlexAddr
alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
alex_accept = listArray (0::Int,17) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[],[],[]]
{-# LINE 32 "LexGFC.x" #-}
tok f p s = f p s
share :: String -> String
share = shareString
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of
PT _ (TS s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N)))
where b s = B s (TS s)
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type AlexInput = (Posn, -- current position,
Char, -- previous char
String) -- current input string
tokens :: String -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: (Posn, Char, String) -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, c, []) = Nothing
alexGetChar (p, _, (c:s)) =
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
alex_action_1 = tok (\p s -> PT p (TS $ share s))
alex_action_2 = tok (\p s -> PT p (eitherResIdent (TV . share) s))
alex_action_3 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s))
alex_action_4 = tok (\p s -> PT p (TI $ share s))
alex_action_5 = tok (\p s -> PT p (TD $ share s))
{-# LINE 1 "GenericTemplate.hs" #-}
{-# LINE 1 "<built-in>" #-}
{-# LINE 1 "<command line>" #-}
{-# LINE 1 "GenericTemplate.hs" #-}
-- -----------------------------------------------------------------------------
-- ALEX TEMPLATE
--
-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
-- it for any purpose whatsoever.
-- -----------------------------------------------------------------------------
-- INTERNALS and main scanner engine
{-# LINE 35 "GenericTemplate.hs" #-}
data AlexAddr = AlexA# Addr#
#if __GLASGOW_HASKELL__ < 503
uncheckedShiftL# = shiftL#
#endif
{-# INLINE alexIndexInt16OffAddr #-}
alexIndexInt16OffAddr (AlexA# arr) off =
#ifdef WORDS_BIGENDIAN
narrow16Int# i
where
i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
low = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 2#
#else
indexInt16OffAddr# arr off
#endif
{-# INLINE alexIndexInt32OffAddr #-}
alexIndexInt32OffAddr (AlexA# arr) off =
#ifdef WORDS_BIGENDIAN
narrow32Int# i
where
i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
(b2 `uncheckedShiftL#` 16#) `or#`
(b1 `uncheckedShiftL#` 8#) `or#` b0)
b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
b0 = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 4#
#else
indexInt32OffAddr# arr off
#endif
#if __GLASGOW_HASKELL__ < 503
quickIndex arr i = arr ! i
#else
-- GHC >= 503, unsafeAt is available from Data.Array.Base.
quickIndex = unsafeAt
#endif
-- -----------------------------------------------------------------------------
-- Main lexing routines
data AlexReturn a
= AlexEOF
| AlexError !AlexInput
| AlexSkip !AlexInput !Int
| AlexToken !AlexInput !Int a
-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act)
alexScan input (I# (sc))
= alexScanUser undefined input (I# (sc))
alexScanUser user input (I# (sc))
= case alex_scan_tkn user input 0# input sc AlexNone of
(AlexNone, input') ->
case alexGetChar input of
Nothing ->
AlexEOF
Just _ ->
AlexError input'
(AlexLastSkip input len, _) ->
AlexSkip input len
(AlexLastAcc k input len, _) ->
AlexToken input len k
-- Push the input through the DFA, remembering the most recent accepting
-- state it encountered.
alex_scan_tkn user orig_input len input s last_acc =
input `seq` -- strict in the input
case s of
-1# -> (last_acc, input)
_ -> alex_scan_tkn' user orig_input len input s last_acc
alex_scan_tkn' user orig_input len input s last_acc =
let
new_acc = check_accs (alex_accept `quickIndex` (I# (s)))
in
new_acc `seq`
case alexGetChar input of
Nothing -> (new_acc, input)
Just (c, new_input) ->
let
base = alexIndexInt32OffAddr alex_base s
(I# (ord_c)) = ord c
offset = (base +# ord_c)
check = alexIndexInt16OffAddr alex_check offset
new_s = if (offset >=# 0#) && (check ==# ord_c)
then alexIndexInt16OffAddr alex_table offset
else alexIndexInt16OffAddr alex_deflt s
in
alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc
where
check_accs [] = last_acc
check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))
check_accs (AlexAccPred a pred : rest)
| pred user orig_input (I# (len)) input
= AlexLastAcc a input (I# (len))
check_accs (AlexAccSkipPred pred : rest)
| pred user orig_input (I# (len)) input
= AlexLastSkip input (I# (len))
check_accs (_ : rest) = check_accs rest
data AlexLastAcc a
= AlexNone
| AlexLastAcc a !AlexInput !Int
| AlexLastSkip !AlexInput !Int
data AlexAcc a user
= AlexAcc a
| AlexAccSkip
| AlexAccPred a (AlexAccPred user)
| AlexAccSkipPred (AlexAccPred user)
type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool
-- -----------------------------------------------------------------------------
-- Predicates on a rule
alexAndPred p1 p2 user in1 len in2
= p1 user in1 len in2 && p2 user in1 len in2
--alexPrevCharIsPred :: Char -> AlexAccPred _
alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input
--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _
alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
--alexRightContext :: Int -> AlexAccPred _
alexRightContext (I# (sc)) user _ _ input =
case alex_scan_tkn user input 0# input sc AlexNone of
(AlexNone, _) -> False
_ -> True
-- TODO: there's no need to find the longest
-- match when checking the right context, just
-- the first match will do.
-- used by wrappers
iUnbox (I# (i)) = i

132
src-3.0/GF/Canon/LexGFC.x
View File

@@ -1,132 +0,0 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
module GF.Canon.LexGFC where
import GF.Data.ErrM -- H
import GF.Data.SharedString -- H
}
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
$d = [0-9] -- digit
$i = [$l $d _ '] -- identifier character
$u = [\0-\255] -- universal: any character
@rsyms = -- reserved words consisting of special symbols
\; | \= | \{ | \} | \: | \- \> | \* \* | \[ | \] | \\ | \. | \( | \) | \_ | \< | \> | \$ | \? | \= \> | \! | \+ \+ | \/ | \@ | \+ | \| | \,
:-
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
{
tok f p s = f p s
share :: String -> String
share = shareString
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of
PT _ (TS s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N)))
where b s = B s (TS s)
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type AlexInput = (Posn, -- current position,
Char, -- previous char
String) -- current input string
tokens :: String -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: (Posn, Char, String) -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, c, []) = Nothing
alexGetChar (p, _, (c:s)) =
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
}

225
src-3.0/GF/Canon/Look.hs
View File

@@ -1,225 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Look
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/20 09:32:56 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.17 $
--
-- lookup in GFC. AR 2003
-----------------------------------------------------------------------------
module GF.Canon.Look (lookupCncInfo,
lookupLin,
lookupLincat,
lookupPrintname,
lookupResInfo,
lookupGlobal,
lookupOptionsCan,
lookupParamValues,
allParamValues,
ccompute
) where
import GF.Canon.AbsGFC
import GF.Canon.GFC
import GF.Grammar.PrGrammar
import GF.Canon.CMacros
----import Values
import GF.Grammar.MMacros
import GF.Grammar.Macros (zIdent)
import qualified GF.Infra.Modules as M
import qualified GF.Canon.CanonToGrammar as CG
import GF.Data.Operations
import GF.Infra.Option
import Control.Monad
import Data.List
-- linearization lookup
lookupCncInfo :: CanonGrammar -> CIdent -> Err Info
lookupCncInfo gr f@(CIQ m c) = do
mt <- M.lookupModule gr m
case mt of
M.ModMod a -> errIn ("module" +++ prt m) $
lookupIdent c $ M.jments a
_ -> prtBad "not concrete module" m
lookupLin :: CanonGrammar -> CIdent -> Err Term
lookupLin gr f = errIn "looking up linearization rule" $ do
info <- lookupCncInfo gr f
case info of
CncFun _ _ t _ -> return t
CncCat _ t _ -> return t
AnyInd _ n -> lookupLin gr $ redirectIdent n f
lookupLincat :: CanonGrammar -> CIdent -> Err CType
lookupLincat gr (CIQ _ c) | elem c [zIdent "String", zIdent "Int", zIdent "Float"] =
return defLinType --- ad hoc; not needed? cf. Grammar.Lookup.lookupLincat
lookupLincat gr f = errIn "looking up linearization type" $ do
info <- lookupCncInfo gr f
case info of
CncCat t _ _ -> return t
AnyInd _ n -> lookupLincat gr $ redirectIdent n f
_ -> prtBad "no lincat found for" f
lookupPrintname :: CanonGrammar -> CIdent -> Err Term
lookupPrintname gr f = errIn "looking up printname" $ do
info <- lookupCncInfo gr f
case info of
CncFun _ _ _ t -> return t
CncCat _ _ t -> return t
AnyInd _ n -> lookupPrintname gr $ redirectIdent n f
lookupResInfo :: CanonGrammar -> CIdent -> Err Info
lookupResInfo gr f@(CIQ m c) = do
mt <- M.lookupModule gr m
case mt of
M.ModMod a -> lookupIdent c $ M.jments a
_ -> prtBad "not resource module" m
lookupGlobal :: CanonGrammar -> CIdent -> Err Term
lookupGlobal gr f = do
info <- lookupResInfo gr f
case info of
ResOper _ t -> return t
AnyInd _ n -> lookupGlobal gr $ redirectIdent n f
_ -> prtBad "cannot find global" f
lookupOptionsCan :: CanonGrammar -> Err Options
lookupOptionsCan gr = do
let fs = M.allFlags gr
os <- mapM CG.redFlag fs
return $ options os
lookupParamValues :: CanonGrammar -> CIdent -> Err [Term]
lookupParamValues gr pt@(CIQ m _) = do
info <- lookupResInfo gr pt
case info of
ResPar ps -> liftM concat $ mapM mkPar ps
AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt
_ -> prtBad "cannot find parameter type" pt
where
mkPar (ParD f co) = do
vs <- liftM combinations $ mapM (allParamValues gr) co
return $ map (Par (CIQ m f)) vs
-- this is needed since param type can also be a record type
allParamValues :: CanonGrammar -> CType -> Err [Term]
allParamValues cnc ptyp = case ptyp of
Cn pc -> lookupParamValues cnc pc
RecType r -> do
let (ls,tys) = unzip [(l,t) | Lbg l t <- r]
tss <- mapM allPV tys
return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss]
TInts n -> return [EInt i | i <- [0..n]]
_ -> prtBad "cannot possibly find parameter values for" ptyp
where
allPV = allParamValues cnc
-- runtime computation on GFC objects
ccompute :: CanonGrammar -> [Term] -> Term -> Err Term
ccompute cnc = vcomp
where
vcomp xs t = do
let xss = variations xs
ts <- mapM (\xx -> comp [] xx t) xss
return $ variants ts
variations xs = combinations [getVariants t | t <- xs]
variants ts = case ts of
[t] -> t
_ -> FV ts
getVariants t = case t of
FV ts -> ts
_ -> [t]
comp g xs t = case t of
Arg (A _ i) -> err (const (return t)) return $ xs !? fromInteger i
Arg (AB _ _ i) -> err (const (return t)) return $ xs !? fromInteger i
I c -> look c
LI c -> lookVar c g
-- short-cut computation of selections: compute the table only if needed
S u v -> do
u' <- compt u
case u' of
T _ [Cas [PW] b] -> compt b
T _ [Cas [PV x] b] -> do
v' <- compt v
comp ((x,v') : g) xs b
T _ cs -> do
v' <- compt v
if noVar v'
then matchPatt cs v' >>= compt
else return $ S u' v'
FV ccs -> do
v' <- compt v
mapM (\c -> compt (S c v')) ccs >>= return . FV
_ -> liftM (S u') $ compt v
P u l -> do
u' <- compt u
case u' of
R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u'))
return $
lookup l [ (x,y) | Ass x y <- rs]
FV rrs -> do
mapM (\r -> compt (P r l)) rrs >>= return . FV
_ -> return $ P u' l
FV ts -> liftM FV (mapM compt ts)
C E b -> compt b
C a E -> compt a
C a b -> do
a' <- compt a
b' <- compt b
return $ case (a',b') of
(E,_) -> b'
(_,E) -> a'
_ -> C a' b'
R rs -> liftM (R . map (uncurry Ass)) $
mapPairsM compt [(l,r) | Ass l r <- rs]
-- only expand the table when the table is really needed: use expandLin
T ty rs -> liftM (T ty . map (uncurry Cas)) $
mapPairsM compt [(l,r) | Cas l r <- rs]
V ptyp ts -> do
ts' <- mapM compt ts
vs0 <- allParamValues cnc ptyp
vs <- mapM term2patt vs0
let cc = [Cas [p] u | (p,u) <- zip vs ts']
return $ T ptyp cc
Par c xs -> liftM (Par c) $ mapM compt xs
K (KS []) -> return E --- should not be needed
_ -> return t
where
compt = comp g xs
look c = lookupGlobal cnc c >>= compt
lookVar c co = case lookup c co of
Just t -> return t
_ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c ---
noVar v = case v of
LI _ -> False
Arg _ -> False
R rs -> all noVar [t | Ass _ t <- rs]
Par _ ts -> all noVar ts
FV ts -> all noVar ts
S x y -> noVar x && noVar y
P t _ -> noVar t
_ -> True --- other cases that can be values to pattern match?

237
src-3.0/GF/Canon/MkGFC.hs
View File

@@ -1,237 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MkGFC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/04 11:45:38 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Canon.MkGFC (prCanonModInfo, prCanon, prCanonMGr,
canon2grammar, grammar2canon, -- buildCanonGrammar,
info2mod,info2def,
trExp, rtExp, rtQIdent) where
import GF.Canon.GFC
import GF.Canon.AbsGFC
import qualified GF.Grammar.Abstract as A
import GF.Grammar.PrGrammar
import GF.Infra.Ident
import GF.Data.Operations
import qualified GF.Infra.Modules as M
prCanonModInfo :: CanonModule -> String
prCanonModInfo = prt . info2mod
prCanon :: CanonGrammar -> String
prCanon = unlines . map prCanonModInfo . M.modules
prCanonMGr :: CanonGrammar -> String
prCanonMGr g = header ++++ prCanon g where
header = case M.greatestAbstract g of
Just a -> prt (MGr (M.allConcretes g a) a [])
_ -> []
canon2grammar :: Canon -> CanonGrammar
canon2grammar (MGr _ _ modules) = canon2grammar (Gr modules) ---- ignoring the header
canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules
mod2info m = case m of
Mod mt e os flags defs ->
let defs' = buildTree $ map def2info defs
(a,mt') = case mt of
MTAbs a -> (a,M.MTAbstract)
MTRes a -> (a,M.MTResource)
MTCnc a x -> (a,M.MTConcrete x)
MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y))
in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs'))
where
ee (Ext m) = map M.inheritAll m
ee _ = []
oo (Opens ms) = map M.oSimple ms
oo _ = []
grammar2canon :: CanonGrammar -> Canon
grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules
info2mod :: (Ident, M.ModInfo Ident Flag Info) -> Module
info2mod m = case m of
(a, M.ModMod (M.Module mt _ flags me os defs)) ->
let defs' = map info2def $ tree2list defs
mt' = case mt of
M.MTAbstract -> MTAbs a
M.MTResource -> MTRes a
M.MTConcrete x -> MTCnc a x
M.MTTransfer (M.OSimple _ x) (M.OSimple _ y) -> MTTrans a x y
in
Mod mt' (gfcE me) (gfcO os) flags defs'
where
gfcE = ifNull NoExt Ext . map fst
gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os]
-- these translations are meant to be trivial
defs2infos = sorted2tree . map def2info
def2info d = case d of
AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs))
AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df))
AbsDTrans c t -> (c,AbsTrans (trExp t))
ResDPar c df -> (c,ResPar df)
ResDOper c ty df -> (c,ResOper ty df)
CncDCat c ty df pr -> (c, CncCat ty df pr)
CncDFun f c xs li pr -> (f, CncFun c xs li pr)
AnyDInd c b m -> (c, AnyInd (b == Canon) m)
-- from file to internal
trCont cont = [(x,trExp t) | Decl x t <- cont]
trFs = map trQIdent
trExp :: Exp -> A.Term
trExp t = case t of
EProd x a b -> A.Prod x (trExp a) (trExp b)
EAbs x b -> A.Abs x (trExp b)
EApp f a -> A.App (trExp f) (trExp a)
EEq eqs -> A.Eqs [(map trPt ps, trExp e) | Equ ps e <- eqs]
EData -> A.EData
_ -> trAt t
where
trAt (EAtom t) = case t of
AC c -> (uncurry A.Q) $ trQIdent c
AD c -> (uncurry A.QC) $ trQIdent c
AV v -> A.Vr v
AM i -> A.Meta $ A.MetaSymb $ fromInteger i
AT s -> A.Sort $ prt s
AS s -> A.K s
AI i -> A.EInt $ i
AF i -> A.EFloat $ i
trPt p = case p of
APC mc ps -> let (m,c) = trQIdent mc in A.PP m c (map trPt ps)
APV x -> A.PV x
APS s -> A.PString s
API i -> A.PInt $ i
APF i -> A.PFloat $ i
APW -> A.PW
trQIdent (CIQ m c) = (m,c)
-- from internal to file
infos2defs = map info2def . tree2list
info2def d = case d of
(c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs)
(c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df)
(c,AbsTrans t) -> AbsDTrans c (rtExp t)
(c,ResPar df) -> ResDPar c df
(c,ResOper ty df) -> ResDOper c ty df
(c,CncCat ty df pr) -> CncDCat c ty df pr
(f,CncFun c xs li pr) -> CncDFun f c xs li pr
(c,AnyInd b m) -> AnyDInd c (if b then Canon else NonCan) m
rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont]
rtFs = map rtQIdent
rtExp :: A.Term -> Exp
rtExp t = case t of
A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b)
A.Abs x b -> EAbs (rtIdent x) (rtExp b)
A.App f a -> EApp (rtExp f) (rtExp a)
A.Eqs eqs -> EEq [Equ (map rtPt ps) (rtExp e) | (ps,e) <- eqs]
A.EData -> EData
_ -> EAtom $ rtAt t
where
rtAt t = case t of
A.Q m c -> AC $ rtQIdent (m,c)
A.QC m c -> AD $ rtQIdent (m,c)
A.Vr v -> AV v
A.Meta i -> AM $ toInteger $ A.metaSymbInt i
A.Sort "Type" -> AT SType
A.K s -> AS s
A.EInt i -> AI $ toInteger i
_ -> error $ "MkGFC.rt not defined for" +++ show t
rtPt p = case p of
A.PP m c ps -> APC (rtQIdent (m,c)) (map rtPt ps)
A.PV x -> APV x
A.PString s -> APS s
A.PInt i -> API $ toInteger i
A.PW -> APW
_ -> error $ "MkGFC.rt not defined for" +++ show p
rtQIdent :: (Ident, Ident) -> CIdent
rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c)
rtIdent x
| isWildIdent x = identC "h_" --- needed in declarations
| otherwise = identC $ prt x ---
{-
-- the following is called in GetGFC to read gfc files line
-- by line. It does not save memory, though, and is therefore
-- not used.
buildCanonGrammar :: Int -> CanonGrammar -> Line -> (CanonGrammar,Int)
buildCanonGrammar n gr0 line = mgr $ case line of
-- LMulti ids id
LHeader mt ext op -> newModule mt ext op
LFlag f@(Flg (IC "modulesize") (IC n)) -> initModule f $ read $ tail n
LFlag flag -> newFlag flag
LDef def -> newDef $ def2info def
-- LEnd -> cleanNames
_ -> M.modules gr0
where
newModule mt ext op = mod2info (Mod mt ext op [] []) : mods
initModule f i = case actm of
(name, M.ModMod (M.Module mt com flags ee oo defs)) ->
(name, M.ModMod (M.Module mt com (f:flags) ee oo (newtree i))) : tmods
newFlag f = case actm of
(name, M.ModMod (M.Module mt com flags ee oo defs)) ->
(name, M.ModMod (M.Module mt com (f:flags) ee oo defs)) : tmods
newDef d = case actm of
(name, M.ModMod (M.Module mt com flags ee oo defs)) ->
(name, M.ModMod (M.Module mt com flags ee oo
(upd (padd 8 n) d defs))) : tmods
-- cleanNames = case actm of
-- (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
-- (name, M.ModMod (M.Module mt com (reverse flags) ee oo
-- (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods
actm = head mods -- only used when a new mod has been created
mods = M.modules gr0
tmods = tail mods
mgr ms = (M.MGrammar ms, case line of
LDef _ -> n+1
LEnd -> 1
_ -> n
)
-- create an initial tree with who-cares value
newtree (i :: Int) = emptyBinTree
-- newtree (i :: Int) = sorted2tree [
-- (padd 8 k, ResPar []) |
-- k <- [1..i]] --- padd (length (show i))
padd l k = 0
-- padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk)
upd _ d defs = updateTree d defs
-- upd n d@(f,t) defs = case defs of
-- NT -> BT (merg n f,t) NT NT --- should not happen
-- BT c@(a,_) left right
-- | n < a -> let left' = upd n d left in BT c left' right
-- | n > a -> let right' = upd n d right in BT c left right'
-- | otherwise -> BT (merg n f,t) left right
-- merg (IC n) (IC f) = IC (n ++ f)
-}

2142
src-3.0/GF/Canon/ParGFC.hs
View File

File diff suppressed because one or more lines are too long

385
src-3.0/GF/Canon/ParGFC.y
View File

@@ -1,385 +0,0 @@
-- This Happy file was machine-generated by the BNF converter
{
module GF.Canon.ParGFC where
import GF.Canon.AbsGFC
import GF.Canon.LexGFC
import GF.Data.ErrM -- H
import GF.Infra.Ident -- H
}
%name pCanon Canon
%name pLine Line
-- no lexer declaration
%monad { Err } { thenM } { returnM }
%tokentype { Token }
%token
';' { PT _ (TS ";") }
'=' { PT _ (TS "=") }
'{' { PT _ (TS "{") }
'}' { PT _ (TS "}") }
':' { PT _ (TS ":") }
'->' { PT _ (TS "->") }
'**' { PT _ (TS "**") }
'[' { PT _ (TS "[") }
']' { PT _ (TS "]") }
'\\' { PT _ (TS "\\") }
'.' { PT _ (TS ".") }
'(' { PT _ (TS "(") }
')' { PT _ (TS ")") }
'_' { PT _ (TS "_") }
'<' { PT _ (TS "<") }
'>' { PT _ (TS ">") }
'$' { PT _ (TS "$") }
'?' { PT _ (TS "?") }
'=>' { PT _ (TS "=>") }
'!' { PT _ (TS "!") }
'++' { PT _ (TS "++") }
'/' { PT _ (TS "/") }
'@' { PT _ (TS "@") }
'+' { PT _ (TS "+") }
'|' { PT _ (TS "|") }
',' { PT _ (TS ",") }
'Ints' { PT _ (TS "Ints") }
'Str' { PT _ (TS "Str") }
'Type' { PT _ (TS "Type") }
'abstract' { PT _ (TS "abstract") }
'cat' { PT _ (TS "cat") }
'concrete' { PT _ (TS "concrete") }
'data' { PT _ (TS "data") }
'flags' { PT _ (TS "flags") }
'fun' { PT _ (TS "fun") }
'grammar' { PT _ (TS "grammar") }
'in' { PT _ (TS "in") }
'lin' { PT _ (TS "lin") }
'lincat' { PT _ (TS "lincat") }
'of' { PT _ (TS "of") }
'open' { PT _ (TS "open") }
'oper' { PT _ (TS "oper") }
'param' { PT _ (TS "param") }
'pre' { PT _ (TS "pre") }
'resource' { PT _ (TS "resource") }
'table' { PT _ (TS "table") }
'transfer' { PT _ (TS "transfer") }
'variants' { PT _ (TS "variants") }
L_ident { PT _ (TV $$) }
L_quoted { PT _ (TL $$) }
L_integ { PT _ (TI $$) }
L_err { _ }
%%
Ident :: { Ident } : L_ident { identC $1 } -- H
String :: { String } : L_quoted { $1 }
Integer :: { Integer } : L_integ { (read $1) :: Integer }
Canon :: { Canon }
Canon : 'grammar' ListIdent 'of' Ident ';' ListModule { MGr $2 $4 (reverse $6) }
| ListModule { Gr (reverse $1) }
Line :: { Line }
Line : 'grammar' ListIdent 'of' Ident ';' { LMulti $2 $4 }
| ModType '=' Extend Open '{' { LHeader $1 $3 $4 }
| Flag ';' { LFlag $1 }
| Def ';' { LDef $1 }
| '}' { LEnd }
Module :: { Module }
Module : ModType '=' Extend Open '{' ListFlag ListDef '}' { Mod $1 $3 $4 (reverse $6) (reverse $7) }
ModType :: { ModType }
ModType : 'abstract' Ident { MTAbs $2 }
| 'concrete' Ident 'of' Ident { MTCnc $2 $4 }
| 'resource' Ident { MTRes $2 }
| 'transfer' Ident ':' Ident '->' Ident { MTTrans $2 $4 $6 }
ListModule :: { [Module] }
ListModule : {- empty -} { [] }
| ListModule Module { flip (:) $1 $2 }
Extend :: { Extend }
Extend : ListIdent '**' { Ext $1 }
| {- empty -} { NoExt }
Open :: { Open }
Open : 'open' ListIdent 'in' { Opens $2 }
| {- empty -} { NoOpens }
Flag :: { Flag }
Flag : 'flags' Ident '=' Ident { Flg $2 $4 }
Def :: { Def }
Def : 'cat' Ident '[' ListDecl ']' '=' ListCIdent { AbsDCat $2 $4 (reverse $7) }
| 'fun' Ident ':' Exp '=' Exp { AbsDFun $2 $4 $6 }
| 'transfer' Ident '=' Exp { AbsDTrans $2 $4 }
| 'param' Ident '=' ListParDef { ResDPar $2 $4 }
| 'oper' Ident ':' CType '=' Term { ResDOper $2 $4 $6 }
| 'lincat' Ident '=' CType '=' Term ';' Term { CncDCat $2 $4 $6 $8 }
| 'lin' Ident ':' CIdent '=' '\\' ListArgVar '->' Term ';' Term { CncDFun $2 $4 $7 $9 $11 }
| Ident Status 'in' Ident { AnyDInd $1 $2 $4 }
ParDef :: { ParDef }
ParDef : Ident ListCType { ParD $1 (reverse $2) }
Status :: { Status }
Status : 'data' { Canon }
| {- empty -} { NonCan }
CIdent :: { CIdent }
CIdent : Ident '.' Ident { CIQ $1 $3 }
Exp1 :: { Exp }
Exp1 : Exp1 Exp2 { EApp $1 $2 }
| Exp2 { $1 }
Exp :: { Exp }
Exp : '(' Ident ':' Exp ')' '->' Exp { EProd $2 $4 $7 }
| '\\' Ident '->' Exp { EAbs $2 $4 }
| '{' ListEquation '}' { EEq (reverse $2) }
| Exp1 { $1 }
Exp2 :: { Exp }
Exp2 : Atom { EAtom $1 }
| 'data' { EData }
| '(' Exp ')' { $2 }
Sort :: { Sort }
Sort : 'Type' { SType }
Equation :: { Equation }
Equation : ListAPatt '->' Exp { Equ (reverse $1) $3 }
APatt :: { APatt }
APatt : '(' CIdent ListAPatt ')' { APC $2 (reverse $3) }
| Ident { APV $1 }
| String { APS $1 }
| Integer { API $1 }
| '_' { APW }
ListDecl :: { [Decl] }
ListDecl : {- empty -} { [] }
| Decl { (:[]) $1 }
| Decl ';' ListDecl { (:) $1 $3 }
ListAPatt :: { [APatt] }
ListAPatt : {- empty -} { [] }
| ListAPatt APatt { flip (:) $1 $2 }
ListEquation :: { [Equation] }
ListEquation : {- empty -} { [] }
| ListEquation Equation ';' { flip (:) $1 $2 }
Atom :: { Atom }
Atom : CIdent { AC $1 }
| '<' CIdent '>' { AD $2 }
| '$' Ident { AV $2 }
| '?' Integer { AM $2 }
| String { AS $1 }
| Integer { AI $1 }
| Sort { AT $1 }
Decl :: { Decl }
Decl : Ident ':' Exp { Decl $1 $3 }
CType :: { CType }
CType : '{' ListLabelling '}' { RecType $2 }
| '(' CType '=>' CType ')' { Table $2 $4 }
| CIdent { Cn $1 }
| 'Str' { TStr }
| 'Ints' Integer { TInts $2 }
Labelling :: { Labelling }
Labelling : Label ':' CType { Lbg $1 $3 }
Term2 :: { Term }
Term2 : ArgVar { Arg $1 }
| CIdent { I $1 }
| '<' CIdent ListTerm2 '>' { Par $2 (reverse $3) }
| '$' Ident { LI $2 }
| '{' ListAssign '}' { R $2 }
| Integer { EInt $1 }
| Tokn { K $1 }
| '[' ']' { E }
| '(' Term ')' { $2 }
Term1 :: { Term }
Term1 : Term2 '.' Label { P $1 $3 }
| 'table' CType '{' ListCase '}' { T $2 $4 }
| 'table' CType '[' ListTerm2 ']' { V $2 (reverse $4) }
| Term1 '!' Term2 { S $1 $3 }
| 'variants' '{' ListTerm2 '}' { FV (reverse $3) }
| Term2 { $1 }
Term :: { Term }
Term : Term '++' Term1 { C $1 $3 }
| Term1 { $1 }
Tokn :: { Tokn }
Tokn : String { KS $1 }
| '[' 'pre' ListString '{' ListVariant '}' ']' { KP (reverse $3) $5 }
Assign :: { Assign }
Assign : Label '=' Term { Ass $1 $3 }
Case :: { Case }
Case : ListPatt '=>' Term { Cas (reverse $1) $3 }
Variant :: { Variant }
Variant : ListString '/' ListString { Var (reverse $1) (reverse $3) }
Label :: { Label }
Label : Ident { L $1 }
| '$' Integer { LV $2 }
ArgVar :: { ArgVar }
ArgVar : Ident '@' Integer { A $1 $3 }
| Ident '+' Integer '@' Integer { AB $1 $3 $5 }
Patt :: { Patt }
Patt : '(' CIdent ListPatt ')' { PC $2 (reverse $3) }
| Ident { PV $1 }
| '_' { PW }
| '{' ListPattAssign '}' { PR $2 }
| Integer { PI $1 }
PattAssign :: { PattAssign }
PattAssign : Label '=' Patt { PAss $1 $3 }
ListFlag :: { [Flag] }
ListFlag : {- empty -} { [] }
| ListFlag Flag ';' { flip (:) $1 $2 }
ListDef :: { [Def] }
ListDef : {- empty -} { [] }
| ListDef Def ';' { flip (:) $1 $2 }
ListParDef :: { [ParDef] }
ListParDef : {- empty -} { [] }
| ParDef { (:[]) $1 }
| ParDef '|' ListParDef { (:) $1 $3 }
ListCType :: { [CType] }
ListCType : {- empty -} { [] }
| ListCType CType { flip (:) $1 $2 }
ListCIdent :: { [CIdent] }
ListCIdent : {- empty -} { [] }
| ListCIdent CIdent { flip (:) $1 $2 }
ListAssign :: { [Assign] }
ListAssign : {- empty -} { [] }
| Assign { (:[]) $1 }
| Assign ';' ListAssign { (:) $1 $3 }
ListArgVar :: { [ArgVar] }
ListArgVar : {- empty -} { [] }
| ArgVar { (:[]) $1 }
| ArgVar ',' ListArgVar { (:) $1 $3 }
ListLabelling :: { [Labelling] }
ListLabelling : {- empty -} { [] }
| Labelling { (:[]) $1 }
| Labelling ';' ListLabelling { (:) $1 $3 }
ListCase :: { [Case] }
ListCase : {- empty -} { [] }
| Case { (:[]) $1 }
| Case ';' ListCase { (:) $1 $3 }
ListTerm2 :: { [Term] }
ListTerm2 : {- empty -} { [] }
| ListTerm2 Term2 { flip (:) $1 $2 }
ListString :: { [String] }
ListString : {- empty -} { [] }
| ListString String { flip (:) $1 $2 }
ListVariant :: { [Variant] }
ListVariant : {- empty -} { [] }
| Variant { (:[]) $1 }
| Variant ';' ListVariant { (:) $1 $3 }
ListPattAssign :: { [PattAssign] }
ListPattAssign : {- empty -} { [] }
| PattAssign { (:[]) $1 }
| PattAssign ';' ListPattAssign { (:) $1 $3 }
ListPatt :: { [Patt] }
ListPatt : {- empty -} { [] }
| ListPatt Patt { flip (:) $1 $2 }
ListIdent :: { [Ident] }
ListIdent : {- empty -} { [] }
| Ident { (:[]) $1 }
| Ident ',' ListIdent { (:) $1 $3 }
{
returnM :: a -> Err a
returnM = return
thenM :: Err a -> (a -> Err b) -> Err b
thenM = (>>=)
happyError :: [Token] -> Err a
happyError ts =
Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
myLexer = tokens
}

46
src-3.0/GF/Canon/PrExp.hs
View File

@@ -1,46 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PrExp
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:28 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
-- print trees without qualifications
-----------------------------------------------------------------------------
module GF.Canon.PrExp (prExp) where
import GF.Canon.AbsGFC
import GF.Canon.GFC
import GF.Data.Operations
prExp :: Exp -> String
prExp e = case e of
EApp f a -> pr1 f +++ pr2 a
EAbsR x b -> "\\" ++ prtt x +++ "->" +++ prExp b
EAbs x _ b -> prExp $ EAbsR x b
EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
EAtomR a -> prAtom a
EAtom a _ -> prAtom a
_ -> prtt e
where
pr1 e = case e of
EAbsR _ _ -> prParenth $ prExp e
EAbs _ _ _ -> prParenth $ prExp e
EProd _ _ _ -> prParenth $ prExp e
_ -> prExp e
pr2 e = case e of
EApp _ _ -> prParenth $ prExp e
_ -> pr1 e
prAtom a = case a of
AC c -> prCIdent c
AD c -> prCIdent c
_ -> prtt a
prCIdent (CIQ _ c) = prtt c

376
src-3.0/GF/Canon/PrintGFC.hs
View File

@@ -1,376 +0,0 @@
module GF.Canon.PrintGFC where
-- pretty-printer generated by the BNF converter, except handhacked spacing --H
import GF.Infra.Ident --H
import GF.Canon.AbsGFC
import Data.Char
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
docs :: ShowS -> Doc
docs x y = concatD [spc, doc x, spc ] y
spc = doc (showString "&")
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"*" :ts -> realnew . rend i ts --H
"&":"&":ts -> showChar ' ' . rend i ts --H
"&" :ts -> rend i ts --H
t :ts -> showString t . rend i ts
_ -> id
realnew = showChar '\n' --H
{-
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"*NEW" :ts -> realnew . rend i ts --H
"<" :ts -> showString "<" . rend i ts --H
"$" :ts -> showString "$" . rend i ts --H
"?" :ts -> showString "?" . rend i ts --H
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . showChar '}' . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "@" :ts -> showString t . showChar '@' . rend i ts
t : "," :ts -> showString t . showChar ',' . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t : ">" :ts -> showString t . showChar '>' . rend i ts --H
t : "." :ts -> showString t . showChar '.' . rend i ts --H
t@"=>" :ts -> showString t . rend i ts --H
t@"->" :ts -> showString t . rend i ts --H
t :ts -> realspace t . rend i ts --H
_ -> id
space t = showString t . showChar ' ' -- H
realspace t = showString t . (\s -> if null s then "" else (' ':s)) -- H
new i s = s -- H
realnew = showChar '\n' --H
-}
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
prtList :: [a] -> Doc
prtList = concatD . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = docs (shows x)
instance Print Double where
prt _ x = docs (shows x)
instance Print Ident where
prt _ i = docs (showString $ prIdent i) -- H
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Canon where
prt i e = case e of
MGr ids id modules -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc , doc (showString "of") , spc, prt 0 id , doc (showString ";") , prt 0 modules])
Gr modules -> prPrec i 0 (concatD [prt 0 modules])
instance Print Line where
prt i e = case e of
LMulti ids id -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc, doc (showString "of") , spc, prt 0 id , doc (showString ";")])
LHeader modtype extend open -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{")])
LFlag flag -> prPrec i 0 (concatD [prt 0 flag , doc (showString ";")])
LDef def -> prPrec i 0 (concatD [prt 0 def , doc (showString ";")])
LEnd -> prPrec i 0 (concatD [doc (showString "}")])
instance Print Module where
prt i e = case e of
Mod modtype extend open flags defs -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{") , prt 0 flags , prt 0 defs , doc (showString "}")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print ModType where
prt i e = case e of
MTAbs id -> prPrec i 0 (concatD [spc, doc (showString "abstract") , spc , prt 0 id])
MTCnc id0 id -> prPrec i 0 (concatD [spc, doc (showString "concrete") , spc, prt 0 id0 , spc, doc (showString "of") , spc, prt 0 id])
MTRes id -> prPrec i 0 (concatD [spc, doc (showString "resource") , spc, prt 0 id])
MTTrans id0 id1 id -> prPrec i 0 (concatD [spc, doc (showString "transfer") , spc, prt 0 id0 , doc (showString ":") , prt 0 id1 , doc (showString "->") , prt 0 id])
instance Print Extend where
prt i e = case e of
Ext ids -> prPrec i 0 (concatD [prt 0 ids , doc (showString "**")])
NoExt -> prPrec i 0 (concatD [])
instance Print Open where
prt i e = case e of
Opens ids -> prPrec i 0 (concatD [spc, doc (showString "open") , spc, prt 0 ids , docs (showString "in")])
NoOpens -> prPrec i 0 (concatD [])
instance Print Flag where
prt i e = case e of
Flg id0 id -> prPrec i 0 (concatD [spc, doc (showString "flags") , spc, prt 0 id0 , doc (showString "=") , prt 0 id])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Def where
prt i e = case e of
AbsDCat id decls cidents -> prPrec i 0 (concatD [docs (showString "cat") , prt 0 id , doc (showString "[") , prt 0 decls , doc (showString "]") , doc (showString "=") , prt 0 cidents])
AbsDFun id exp0 exp -> prPrec i 0 (concatD [docs (showString "fun") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
AbsDTrans id exp -> prPrec i 0 (concatD [docs (showString "transfer") , prt 0 id , doc (showString "=") , prt 0 exp])
ResDPar id pardefs -> prPrec i 0 (concatD [docs (showString "param") , prt 0 id , doc (showString "=") , prt 0 pardefs])
ResDOper id ctype term -> prPrec i 0 (concatD [docs (showString "oper") , prt 0 id , doc (showString ":") , prt 0 ctype , doc (showString "=") , prt 0 term])
CncDCat id ctype term0 term -> prPrec i 0 (concatD [docs (showString "lincat") , prt 0 id , doc (showString "=") , prt 0 ctype , doc (showString "=") , prt 0 term0 , doc (showString ";") , prt 0 term])
CncDFun id cident argvars term0 term -> prPrec i 0 (concatD [docs (showString "lin") , prt 0 id , doc (showString ":") , prt 0 cident , doc (showString "=") , doc (showString "\\") , prt 0 argvars , doc (showString "->") , prt 0 term0 , doc (showString ";") , prt 0 term])
AnyDInd id0 status id -> prPrec i 0 (concatD [prt 0 id0 , prt 0 status , docs (showString "in") , prt 0 id])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";"), doc (showString "*") , prt 0 xs]) -- H
instance Print ParDef where
prt i e = case e of
ParD id ctypes -> prPrec i 0 (concatD [prt 0 id , prt 0 ctypes])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
instance Print Status where
prt i e = case e of
Canon -> prPrec i 0 (concatD [docs (showString "data")])
NonCan -> prPrec i 0 (concatD [])
instance Print CIdent where
prt i e = case e of
CIQ id0 id -> prPrec i 0 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Exp where
prt i e = case e of
EApp exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , prt 2 exp])
EProd id exp0 exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp])
EAbs id exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 id , doc (showString "->") , prt 0 exp])
EAtom atom -> prPrec i 2 (concatD [prt 0 atom])
EData -> prPrec i 2 (concatD [docs (showString "data")])
EEq equations -> prPrec i 0 (concatD [doc (showString "{") , prt 0 equations , doc (showString "}")])
instance Print Sort where
prt i e = case e of
SType -> prPrec i 0 (concatD [docs (showString "Type")])
instance Print Equation where
prt i e = case e of
Equ apatts exp -> prPrec i 0 (concatD [prt 0 apatts , doc (showString "->") , prt 0 exp])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print APatt where
prt i e = case e of
APC cident apatts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 apatts , doc (showString ")")])
APV id -> prPrec i 0 (concatD [prt 0 id])
APS str -> prPrec i 0 (concatD [prt 0 str])
API n -> prPrec i 0 (concatD [prt 0 n])
APF n -> prPrec i 0 (concatD [prt 0 n])
APW -> prPrec i 0 (concatD [doc (showString "_")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Atom where
prt i e = case e of
AC cident -> prPrec i 0 (concatD [prt 0 cident])
AD cident -> prPrec i 0 (concatD [doc (showString "<") , prt 0 cident , doc (showString ">")])
AV id -> prPrec i 0 (concatD [doc (showString "$") , prt 0 id])
AM n -> prPrec i 0 (concatD [doc (showString "?") , prt 0 n])
AS str -> prPrec i 0 (concatD [prt 0 str])
AI n -> prPrec i 0 (concatD [prt 0 n])
AT sort -> prPrec i 0 (concatD [prt 0 sort])
instance Print Decl where
prt i e = case e of
Decl id exp -> prPrec i 0 (concatD [prt 0 id , doc (showString ":") , prt 0 exp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print CType where
prt i e = case e of
RecType labellings -> prPrec i 0 (concatD [doc (showString "{") , prt 0 labellings , doc (showString "}")])
Table ctype0 ctype -> prPrec i 0 (concatD [doc (showString "(") , prt 0 ctype0 , doc (showString "=>") , prt 0 ctype , doc (showString ")")])
Cn cident -> prPrec i 0 (concatD [prt 0 cident])
TStr -> prPrec i 0 (concatD [docs (showString "Str")])
TInts n -> prPrec i 0 (concatD [docs (showString "Ints") , prt 0 n])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Labelling where
prt i e = case e of
Lbg label ctype -> prPrec i 0 (concatD [prt 0 label , doc (showString ":") , prt 0 ctype])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Term where
prt i e = case e of
Arg argvar -> prPrec i 2 (concatD [prt 0 argvar])
I cident -> prPrec i 2 (concatD [prt 0 cident])
Par cident terms -> prPrec i 2 (concatD [doc (showString "<") , prt 0 cident , prt 2 terms , doc (showString ">")])
LI id -> prPrec i 2 (concatD [doc (showString "$") , prt 0 id])
R assigns -> prPrec i 2 (concatD [doc (showString "{") , prt 0 assigns , doc (showString "}")])
P term label -> prPrec i 1 (concatD [prt 2 term , doc (showString ".") , prt 0 label])
T ctype cases -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "{") , prt 0 cases , doc (showString "}")])
V ctype terms -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "[") , prt 2 terms , doc (showString "]")])
S term0 term -> prPrec i 1 (concatD [prt 1 term0 , doc (showString "!") , prt 2 term])
C term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "++") , prt 1 term])
FV terms -> prPrec i 1 (concatD [docs (showString "variants") , doc (showString "{") , prt 2 terms , doc (showString "}")])
EInt n -> prPrec i 2 (concatD [prt 0 n])
EFloat n -> prPrec i 2 (concatD [prt 0 n])
K tokn -> prPrec i 2 (concatD [prt 0 tokn])
E -> prPrec i 2 (concatD [doc (showString "[") , doc (showString "]")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 2 x , prt 2 xs])
instance Print Tokn where
prt i e = case e of
KS str -> prPrec i 0 (concatD [prt 0 str])
KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , docs (showString "pre") , prt 0 strs , doc (showString "{") , prt 0 variants , doc (showString "}") , doc (showString "]")])
KM str -> prPrec i 0 (concatD [prt 0 str])
instance Print Assign where
prt i e = case e of
Ass label term -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 term])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Case where
prt i e = case e of
Cas patts term -> prPrec i 0 (concatD [prt 0 patts , doc (showString "=>") , prt 0 term])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Variant where
prt i e = case e of
Var strs0 strs -> prPrec i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Label where
prt i e = case e of
L id -> prPrec i 0 (concatD [prt 0 id])
LV n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
instance Print ArgVar where
prt i e = case e of
A id n -> prPrec i 0 (concatD [prt 0 id , doc (showString "@") , prt 0 n])
AB id n0 n -> prPrec i 0 (concatD [prt 0 id , doc (showString "+") , prt 0 n0 , doc (showString "@") , prt 0 n])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Patt where
prt i e = case e of
PC cident patts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 patts , doc (showString ")")])
PV id -> prPrec i 0 (concatD [prt 0 id])
PW -> prPrec i 0 (concatD [docs (showString "_")])
PR pattassigns -> prPrec i 0 (concatD [doc (showString "{") , prt 0 pattassigns , doc (showString "}")])
PI n -> prPrec i 0 (concatD [prt 0 n])
PF n -> prPrec i 0 (concatD [prt 0 n])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print PattAssign where
prt i e = case e of
PAss label patt -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 patt])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])

147
src-3.0/GF/Canon/Share.hs
View File

@@ -1,147 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Share
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 14:15:18 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.12 $
--
-- Optimizations on GFC code: sharing, parametrization, value sets.
--
-- optimization: sharing branches in tables. AR 25\/4\/2003.
-- following advice of Josef Svenningsson
-----------------------------------------------------------------------------
module GF.Canon.Share (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
import GF.Canon.AbsGFC
import GF.Infra.Ident
import GF.Canon.GFC
import qualified GF.Canon.CMacros as C
import GF.Grammar.PrGrammar (prt)
import GF.Data.Operations
import Data.List
import qualified GF.Infra.Modules as M
type OptSpec = [Integer] ---
doOptFactor opt = elem 2 opt
doOptValues opt = elem 3 opt
shareOpt :: OptSpec
shareOpt = []
paramOpt :: OptSpec
paramOpt = [2]
valOpt :: OptSpec
valOpt = [3]
allOpt :: OptSpec
allOpt = [2,3]
shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo)
shareModule opt (i,m) = case m of
M.ModMod (M.Module mt st fs me ops js) ->
(i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
_ -> (i,m)
shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m)
shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m)
shareInfo _ i = i
-- | the function putting together optimizations
shareOptim :: OptSpec -> Ident -> Term -> Term
shareOptim opt c
| doOptFactor opt && doOptValues opt = values . factor c 0
| doOptFactor opt = share . factor c 0
| doOptValues opt = values
| otherwise = share
-- | we need no counter to create new variable names, since variables are
-- local to tables
share :: Term -> Term
share t = case t of
T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant.
R lts -> R [Ass l (share t) | Ass l t <- lts]
P t l -> P (share t) l
S t a -> S (share t) (share a)
C t a -> C (share t) (share a)
FV ts -> FV (map share ts)
_ -> t -- including D, which is always born shared
where
shareT ty = finalize ty . groupC . sortC
sortC :: [(Patt,Term)] -> [(Patt,Term)]
sortC = sortBy $ \a b -> compare (snd a) (snd b)
groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
groupC = groupBy $ \a b -> snd a == snd b
finalize :: CType -> [[(Patt,Term)]] -> Term
finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css]
-- | do even more: factor parametric branches
factor :: Ident -> Int -> Term -> Term
factor c i t = case t of
T _ [_] -> t
T _ [] -> t
T ty cs -> T ty $ factors i [Cas [p] (factor c (i+1) v) | Cas ps v <- cs, p <- ps]
R lts -> R [Ass l (factor c i t) | Ass l t <- lts]
P t l -> P (factor c i t) l
S t a -> S (factor c i t) (factor c i a)
C t a -> C (factor c i t) (factor c i a)
FV ts -> FV (map (factor c i) ts)
_ -> t
where
factors i psvs = -- we know psvs has at least 2 elements
let p = pIdent c i
vs' = map (mkFun p) psvs
in if allEqs vs'
then mkCase p vs'
else psvs
mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val
allEqs (v:vs) = all (==v) vs
mkCase p (v:_) = [Cas [PV p] v]
pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i)
-- | we need to replace subterms
replace :: Term -> Term -> Term -> Term
replace old new trm = case trm of
T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs]
P t l -> P (repl t) l
S t a -> S (repl t) (repl a)
C t a -> C (repl t) (repl a)
FV ts -> FV (map repl ts)
-- these are the important cases, since they can correspond to patterns
Par c ts | trm == old -> new
Par c ts -> Par c (map repl ts)
R _ | isRec && trm == old -> new
R lts -> R [Ass l (repl t) | Ass l t <- lts]
_ -> trm
where
repl = replace old new
isRec = case trm of
R _ -> True
_ -> False
values :: Term -> Term
values t = case t of
T ty [c] -> T ty [Cas p (values t) | Cas p t <- [c]] -- preserve parametrization
T ty cs -> V ty [values t | Cas _ t <- cs] -- assumes proper order
_ -> C.composSafeOp values t

217
src-3.0/GF/Canon/SkelGFC.hs
View File

@@ -1,217 +0,0 @@
module GF.Canon.SkelGFC where
-- Haskell module generated by the BNF converter
import GF.Canon.AbsGFC
import GF.Data.ErrM
import GF.Infra.Ident
type Result = Err String
failure :: Show a => a -> Result
failure x = Bad $ "Undefined case: " ++ show x
transIdent :: Ident -> Result
transIdent x = case x of
Ident str -> failure x
transCanon :: Canon -> Result
transCanon x = case x of
MGr ids id modules -> failure x
Gr modules -> failure x
transLine :: Line -> Result
transLine x = case x of
LMulti ids id -> failure x
LHeader modtype extend open -> failure x
LFlag flag -> failure x
LDef def -> failure x
LEnd -> failure x
transModule :: Module -> Result
transModule x = case x of
Mod modtype extend open flags defs -> failure x
transModType :: ModType -> Result
transModType x = case x of
MTAbs id -> failure x
MTCnc id0 id -> failure x
MTRes id -> failure x
MTTrans id0 id1 id -> failure x
transExtend :: Extend -> Result
transExtend x = case x of
Ext ids -> failure x
NoExt -> failure x
transOpen :: Open -> Result
transOpen x = case x of
Opens ids -> failure x
NoOpens -> failure x
transFlag :: Flag -> Result
transFlag x = case x of
Flg id0 id -> failure x
transDef :: Def -> Result
transDef x = case x of
AbsDCat id decls cidents -> failure x
AbsDFun id exp0 exp -> failure x
AbsDTrans id exp -> failure x
ResDPar id pardefs -> failure x
ResDOper id ctype term -> failure x
CncDCat id ctype term0 term -> failure x
CncDFun id cident argvars term0 term -> failure x
AnyDInd id0 status id -> failure x
transParDef :: ParDef -> Result
transParDef x = case x of
ParD id ctypes -> failure x
transStatus :: Status -> Result
transStatus x = case x of
Canon -> failure x
NonCan -> failure x
transCIdent :: CIdent -> Result
transCIdent x = case x of
CIQ id0 id -> failure x
transExp :: Exp -> Result
transExp x = case x of
EApp exp0 exp -> failure x
EProd id exp0 exp -> failure x
EAbs id exp -> failure x
EAtom atom -> failure x
EData -> failure x
EEq equations -> failure x
transSort :: Sort -> Result
transSort x = case x of
SType -> failure x
transEquation :: Equation -> Result
transEquation x = case x of
Equ apatts exp -> failure x
transAPatt :: APatt -> Result
transAPatt x = case x of
APC cident apatts -> failure x
APV id -> failure x
APS str -> failure x
API n -> failure x
APW -> failure x
transAtom :: Atom -> Result
transAtom x = case x of
AC cident -> failure x
AD cident -> failure x
AV id -> failure x
AM n -> failure x
AS str -> failure x
AI n -> failure x
AT sort -> failure x
transDecl :: Decl -> Result
transDecl x = case x of
Decl id exp -> failure x
transCType :: CType -> Result
transCType x = case x of
RecType labellings -> failure x
Table ctype0 ctype -> failure x
Cn cident -> failure x
TStr -> failure x
TInts n -> failure x
transLabelling :: Labelling -> Result
transLabelling x = case x of
Lbg label ctype -> failure x
transTerm :: Term -> Result
transTerm x = case x of
Arg argvar -> failure x
I cident -> failure x
Par cident terms -> failure x
LI id -> failure x
R assigns -> failure x
P term label -> failure x
T ctype cases -> failure x
V ctype terms -> failure x
S term0 term -> failure x
C term0 term -> failure x
FV terms -> failure x
EInt n -> failure x
K tokn -> failure x
E -> failure x
transTokn :: Tokn -> Result
transTokn x = case x of
KS str -> failure x
KP strs variants -> failure x
KM str -> failure x
transAssign :: Assign -> Result
transAssign x = case x of
Ass label term -> failure x
transCase :: Case -> Result
transCase x = case x of
Cas patts term -> failure x
transVariant :: Variant -> Result
transVariant x = case x of
Var strs0 strs -> failure x
transLabel :: Label -> Result
transLabel x = case x of
L id -> failure x
LV n -> failure x
transArgVar :: ArgVar -> Result
transArgVar x = case x of
A id n -> failure x
AB id n0 n -> failure x
transPatt :: Patt -> Result
transPatt x = case x of
PC cident patts -> failure x
PV id -> failure x
PW -> failure x
PR pattassigns -> failure x
PI n -> failure x
transPattAssign :: PattAssign -> Result
transPattAssign x = case x of
PAss label patt -> failure x

170
src-3.0/GF/Canon/Subexpressions.hs
View File

@@ -1,170 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Subexpressions
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/20 09:32:56 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.4 $
--
-- Common subexpression elimination.
-- all tables. AR 18\/9\/2005.
-----------------------------------------------------------------------------
module GF.Canon.Subexpressions (
elimSubtermsMod, prSubtermStat, unSubelimCanon, unSubelimModule
) where
import GF.Canon.AbsGFC
import GF.Infra.Ident
import GF.Canon.GFC
import GF.Canon.Look
import GF.Grammar.PrGrammar
import GF.Canon.CMacros as C
import GF.Data.Operations
import qualified GF.Infra.Modules as M
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List
{-
This module implements a simple common subexpression elimination
for gfc grammars, to factor out shared subterms in lin rules.
It works in three phases:
(1) collectSubterms collects recursively all subterms of forms table and (P x..y)
from lin definitions (experience shows that only these forms
tend to get shared) and counts how many times they occur
(2) addSubexpConsts takes those subterms t that occur more than once
and creates definitions of form "oper A''n = t" where n is a
fresh number; notice that we assume no ids of this form are in
scope otherwise
(3) elimSubtermsMod goes through lins and the created opers by replacing largest
possible subterms by the newly created identifiers
The optimization is invoked in gf by the flag i -subs.
If an application does not support GFC opers, the effect of this
optimization can be undone by the function unSubelimCanon.
The function unSubelimCanon can be used to diagnostisize how much
cse is possible in the grammar. It is used by the flag pg -printer=subs.
-}
-- exported functions
elimSubtermsMod :: (Ident,CanonModInfo) -> Err (Ident, CanonModInfo)
elimSubtermsMod (mo,m) = case m of
M.ModMod (M.Module mt st fs me ops js) -> do
(tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0)
js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js
return (mo,M.ModMod (M.Module mt st fs me ops js2))
_ -> return (mo,m)
prSubtermStat :: CanonGrammar -> String
prSubtermStat gr = unlines [prt mo ++++ expsIn mo js | (mo,js) <- mos] where
mos = [(i, tree2list (M.jments m)) | (i, M.ModMod m) <- M.modules gr, M.isModCnc m]
expsIn mo js = err id id $ do
(tree,_) <- appSTM (getSubtermsMod mo js) (Map.empty,0)
let list0 = Map.toList tree
let list1 = sortBy (\ (_,(m,_)) (_,(n,_)) -> compare n m) list0
return $ unlines [show n ++ "\t" ++ prt trm | (trm,(n,_)) <- list1]
unSubelimCanon :: CanonGrammar -> CanonGrammar
unSubelimCanon gr@(M.MGrammar modules) =
M.MGrammar $ map unSubelimModule modules
unSubelimModule :: CanonModule -> CanonModule
unSubelimModule mo@(i,m) = case m of
M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) | hasSub ljs ->
(i, M.ModMod (M.Module mt st fs me ops
(rebuild (map unparInfo ljs))))
where ljs = tree2list js
_ -> (i,m)
where
-- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
unparInfo (c,info) = case info of
CncFun k xs t m -> [(c, CncFun k xs (unparTerm t) m)]
ResOper _ _ -> []
_ -> [(c,info)]
unparTerm t = case t of
I c -> errVal t $ liftM unparTerm $ lookupGlobal gr c
_ -> C.composSafeOp unparTerm t
gr = M.MGrammar [mo]
rebuild = buildTree . concat
-- implementation
type TermList = Map Term (Int,Int) -- number of occs, id
type TermM a = STM (TermList,Int) a
addSubexpConsts :: Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)]
addSubexpConsts mo tree lins = do
let opers = [oper id trm | (trm,(_,id)) <- list]
mapM mkOne $ opers ++ lins
where
mkOne (f,def) = case def of
CncFun ci xs trm pn -> do
trm' <- recomp f trm
return (f,CncFun ci xs trm' pn)
ResOper ty trm -> do
trm' <- recomp f trm
return (f,ResOper ty trm')
_ -> return (f,def)
recomp f t = case Map.lookup t tree of
Just (_,id) | ident id /= f -> return $ I $ cident mo id
_ -> composOp (recomp f) t
list = Map.toList tree
oper id trm = (ident id, ResOper TStr trm) --- type TStr does not matter
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
getSubtermsMod mo js = do
mapM (getInfo (collectSubterms mo)) js
(tree0,_) <- readSTM
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getInfo get fi@(f,i) = case i of
CncFun ci xs trm pn -> do
get trm
return $ fi
ResOper ty trm -> do
get trm
return $ fi
_ -> return fi
collectSubterms :: Ident -> Term -> TermM Term
collectSubterms mo t = case t of
Par _ (_:_) -> add t
T ty cs -> do
let (ps,ts) = unzip [(p,t) | Cas p t <- cs]
mapM (collectSubterms mo) ts
add t
V ty ts -> do
mapM (collectSubterms mo) ts
add t
K (KP _ _) -> add t
_ -> composOp (collectSubterms mo) t
where
add t = do
(ts,i) <- readSTM
let
((count,id),next) = case Map.lookup t ts of
Just (nu,id) -> ((nu+1,id), i)
_ -> ((1, i ), i+1)
writeSTM (Map.insert t (count,id) ts, next)
return t --- only because of composOp
ident :: Int -> Ident
ident i = identC ("A''" ++ show i) ---
cident :: Ident -> Int -> CIdent
cident mo = CIQ mo . ident

58
src-3.0/GF/Canon/TestGFC.hs
View File

@@ -1,58 +0,0 @@
-- automatically generated by BNF Converter
module Main where
import IO ( stdin, hGetContents )
import System ( getArgs, getProgName )
import GF.Canon.LexGFC
import GF.Canon.ParGFC
import GF.Canon.SkelGFC
import GF.Canon.PrintGFC
import GF.Canon.AbsGFC
import GF.Infra.Ident
import GF.Data.ErrM
type ParseFun a = [Token] -> Err a
myLLexer = myLexer
type Verbosity = Int
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
showTree v tree
showTree :: (Show a, Print a) => Int -> a -> IO ()
showTree v tree
= do
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO ()
main = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run 2 pCanon
"-s":fs -> mapM_ (runFile 0 pCanon) fs
fs -> mapM_ (runFile 2 pCanon) fs

49
src-3.0/GF/Canon/Unlex.hs
View File

@@ -1,49 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Unlex
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:32 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- elementary text postprocessing. AR 21/11/2001
-----------------------------------------------------------------------------
module GF.Canon.Unlex (formatAsText, unlex, performBinds) where
import GF.Data.Operations
import GF.Data.Str
import Data.Char
import Data.List (isPrefixOf)
formatAsText :: String -> String
formatAsText = unwords . format . cap . words where
format ws = case ws of
w : c : ww | major c -> (w ++ c) : format (cap ww)
w : c : ww | minor c -> (w ++ c) : format ww
c : ww | para c -> "\n\n" : format ww
w : ww -> w : format ww
[] -> []
cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww
cap ((c:cs):ww) = (toUpper c : cs) : ww
cap [] = []
major = flip elem (map (:[]) ".!?")
minor = flip elem (map (:[]) ",:;")
para = (=="&-")
unlex :: [Str] -> String
unlex = formatAsText . performBinds . concat . map sstr . take 1 ----
-- | modified from GF/src/Text by adding hyphen
performBinds :: String -> String
performBinds = unwords . format . words where
format ws = case ws of
w : "-" : u : ws -> format ((w ++ "-" ++ u) : ws)
w : "&+" : u : ws -> format ((w ++ u) : ws)
w : ws -> w : format ws
[] -> []

63
src-3.0/GF/Canon/Unparametrize.hs
View File

@@ -1,63 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Unparametrize
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/14 16:26:21 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.1 $
--
-- Taking away parameters from a canonical grammar. All param
-- types are replaced by {}, and only one branch is left in
-- all tables. AR 14\/9\/2005.
-----------------------------------------------------------------------------
module GF.Canon.Unparametrize (unparametrizeCanon) where
import GF.Canon.AbsGFC
import GF.Infra.Ident
import GF.Canon.GFC
import qualified GF.Canon.CMacros as C
import GF.Data.Operations
import qualified GF.Infra.Modules as M
unparametrizeCanon :: CanonGrammar -> CanonGrammar
unparametrizeCanon (M.MGrammar modules) =
M.MGrammar $ map unparModule modules where
unparModule (i,m) = case m of
M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) ->
let me' = [(unparIdent j,incl) | (j,incl) <- me] in
(unparIdent i, M.ModMod (M.Module mt st fs me' ops (mapTree unparInfo js)))
_ -> (i,m)
unparInfo (c,info) = case info of
CncCat ty t m -> (c, CncCat (unparCType ty) (unparTerm t) m)
CncFun k xs t m -> (c, CncFun k xs (unparTerm t) m)
AnyInd b i -> (c, AnyInd b (unparIdent i))
_ -> (c,info)
unparCType ty = case ty of
RecType ls -> RecType [Lbg lab (unparCType t) | Lbg lab t <- ls]
Table _ v -> unparCType v --- Table unitType (unparCType v)
Cn _ -> unitType
_ -> ty
unparTerm t = case t of
Par _ _ -> unitTerm
T _ cs -> unparTerm (head [t | Cas _ t <- cs])
V _ ts -> unparTerm (head ts)
S t _ -> unparTerm t
{-
T _ cs -> V unitType [unparTerm (head [t | Cas _ t <- cs])]
V _ ts -> V unitType [unparTerm (head ts)]
S t _ -> S (unparTerm t) unitTerm
-}
_ -> C.composSafeOp unparTerm t
unitType = RecType []
unitTerm = R []
unparIdent (IC s) = IC $ "UP_" ++ s

20
src-3.0/GF/Canon/log.txt
View File

@@ -1,20 +0,0 @@
GFCC, 6/9/2006
66661 24 Par remaining to be sent to GFC
66662 0 not covered by mkTerm
66663 36 label not in numeric format in mkTerm
66664 2 label not found in symbol table
66665 36 projection from deeper than just arg var: NP.agr.n
66667 0 parameter value not found in symbol table
66668 1 variable in parameter argument
66664 2
66665 125 missing: (VP.s!vf).fin
66668 1
66661/3 24 same lines:
66664 2
66668 1

1078
src-3.0/GF/Compile/CheckGrammar.hs
View File

File diff suppressed because it is too large Load Diff

401
src-3.0/GF/Compile/Compile.hs
View File

@@ -1,401 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Compile
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/05 20:02:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.45 $
--
-- The top-level compilation chain from source file to gfc\/gfr.
-----------------------------------------------------------------------------
module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne,
CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts,
getGFEFiles) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Infra.CompactPrint
import GF.Grammar.PrGrammar
import GF.Compile.Update
import GF.Grammar.Lookup
import GF.Infra.Modules
import GF.Infra.ReadFiles
import GF.Compile.ShellState
import GF.Compile.MkResource
---- import MkUnion
-- the main compiler passes
import GF.Compile.GetGrammar
import GF.Compile.Extend
import GF.Compile.Rebuild
import GF.Compile.Rename
import GF.Grammar.Refresh
import GF.Compile.CheckGrammar
import GF.Compile.Optimize
import GF.Compile.Evaluate
import GF.Compile.GrammarToCanon
--import GF.Devel.GrammarToGFCC -----
import GF.Devel.OptimizeGF (subexpModule,unsubexpModule)
import GF.Canon.Share
import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
import GF.UseGrammar.Linear (unoptimizeCanonMod) ----
import qualified GF.Canon.CanonToGrammar as CG
import qualified GF.Canon.GFC as GFC
import qualified GF.Canon.MkGFC as MkGFC
import GF.Canon.GetGFC
import GF.Data.Operations
import GF.Infra.UseIO
import GF.Text.UTF8 ----
import GF.System.Arch
import Control.Monad
import System.Directory
import System.FilePath
-- | in batch mode: write code in a file
batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
where
defOpts = options [emitCode]
batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f
where
defOpts = options [emitCode, optimizeCanon]
batchCompileOld f = compileOld defOpts f
where
defOpts = options [emitCode]
-- | compile with one module as starting point
-- command-line options override options (marked by --#) in the file
-- As for path: if it is read from file, the file path is prepended to each name.
-- If from command line, it is used as it is.
compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv
---- IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))]))
compileModule opts st0 file |
oElem showOld opts ||
elem suff [".cf",".ebnf",".gfm"] = do
let putp = putPointE opts
let putpp = putPointEsil opts
let path = [] ----
grammar1 <- case suff of
".cf" -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file
".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file
".gfm" -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file
_ -> putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
let mods = modules grammar1
let env = compileEnvShSt st0 []
foldM (comp putpp path) env mods
where
suff = takeExtensions file
comp putpp path env sm0 = do
(k',sm,eenv') <- makeSourceModule opts (fst env) sm0
cm <- putpp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file ---
extendCompileEnvInt env (k',sm,cm) eenv' ft
compileModule opts1 st0 file = do
opts0 <- ioeIO $ getOptionsFromFile file
let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
let opts = addOptions opts1 opts0
let fpath = dropFileName file
ps0 <- ioeIO $ pathListOpts opts fpath
let ps1 = if (useFileOpt && not useLineOpt)
then (ps0 ++ map (combine fpath) ps0)
else ps0
ps <- ioeIO $ extendPathEnv ps1
let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
let st = st0 --- if useFileOpt then emptyShellState else st0
let rfs = [(m,t) | (m,(_,t)) <- readFiles st]
let file' = if useFileOpt then takeFileName file else file -- to find file itself
files <- getAllFiles opts ps rfs file'
ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
let names = map justModuleName files
ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
let env0 = compileEnvShSt st names
(e,mm) <- foldIOE (compileOne opts) env0 files
maybe (return ()) putStrLnE mm
return e
getReadTimes file = do
t <- ioeIO getNowTime
let m = justModuleName file
return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)]
compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv
compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where
cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
notInc i = notElem (prt i) $ map dropExtension fs
notIns i = notElem (prt i) $ map dropExtension fs
fts = readFiles st
eenv = evalEnv st
pathListOpts :: Options -> FileName -> IO [InitPath]
pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
reverseModules (MGrammar ms) = MGrammar $ reverse ms
keepResModules :: Options -> SourceGrammar -> SourceGrammar
keepResModules opts gr =
if oElem retainOpers opts
then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
else emptyMGrammar
-- | the environment
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv)
emptyCompileEnv :: TimedCompileEnv
emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[])
extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft =
return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later
extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm)
extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft =
return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts)
type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))])
compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do
let putp = putPointE opts
let putpp = putPointEsil opts
let putpOpt v m act
| oElem beVerbose opts = putp v act
| oElem beSilent opts = putpp v act
| otherwise = ioeIO (putStrFlush m) >> act
let gf = takeExtensions file
let path = dropFileName file
let name = dropExtension file
let mos = modules srcgr
case gf of
-- for multilingual canonical gf, just read the file and update environment
".gfcm" -> do
cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
ft <- getReadTimes file
extendCompileEnvCanon env cgr eenv ft
-- for canonical gf, read the file and update environment, also source env
".gfc" -> do
cm <- putp ("+ reading" +++ file) $ getCanonModule file
let cancgr = updateMGrammar (MGrammar [cm]) cancgr0
sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm
ft <- getReadTimes file
extendCompileEnv env (sm, cm) eenv ft
-- for compiled resource, parse and organize, then update environment
".gfr" -> do
sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file
let sm1 = unsubexpModule sm0
sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1
---- experiment with not optimizing gfr
---- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1
let gfc = gfcFile name
cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
ft <- getReadTimes file
extendCompileEnv env (sm,cm) eenv ft
-- for gf source, do full compilation
_ -> do
--- hack fix to a bug in ReadFiles with reused concrete
let modu = dropExtension file
b1 <- ioeIO $ doesFileExist file
b2 <- ioeIO $ doesFileExist $ gfrFile modu
if not b1
then if b2
then compileOne opts env $ gfrFile $ modu
else compileOne opts env $ gfcFile $ modu
else do
sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file
(k',sm,eenv') <- makeSourceModule opts (fst env) sm0
cm <- putpp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file
sm':_ <- case snd sm of
---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm
_ -> return [sm]
extendCompileEnvInt env (k',sm',cm) eenv' ft
-- | dispatch reused resource at early stage
makeSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule,EEnv)
makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of
ModMod m -> case mtype m of
MTReuse c -> do
sm <- ioeErr $ makeReuse gr i (extend m) c
let mo2 = (i, ModMod sm)
mos = modules gr
--- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2
return $ (k,mo2,eenv)
{- ---- obsolete
MTUnion ty imps -> do
mo' <- ioeErr $ makeUnion gr i ty imps
compileSourceModule opts env mo'
-}
_ -> compileSourceModule opts env mo
_ -> compileSourceModule opts env mo
where
putp = putPointE opts
compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule,EEnv)
compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do
let putp = putPointE opts
putpp = putPointEsil opts
mos = modules gr
if (oElem showOld opts && oElem emitCode opts)
then do
let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo]))
putp (" wrote file" +++ file) $ ioeIO $ writeFile file out
else return ()
mo1 <- ioeErr $ rebuildModule mos mo
mo1b <- ioeErr $ extendModule mos mo1
case mo1b of
(_,ModMod n) | not (isCompleteModule n) -> do
return (k,mo1b,eenv) -- refresh would fail, since not renamed
_ -> do
mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b
(mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2
if null warnings then return () else putp warnings $ return ()
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
(mo4,eenv') <-
---- if oElem "check_only" opts
putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
return (k',mo4,eenv')
where
---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
generateModuleCode opts path minfo@(name,info) = do
--- DEPREC
--- if oElem (iOpt "gfcc") opts
--- then ioeIO $ putStrLn $ prGrammar2gfcc minfo
--- else return ()
let pname = path </> prt name
minfo0 <- ioeErr $ redModInfo minfo
let oopts = addOptions opts (iOpts (flagsModule minfo))
optims = maybe "all_subs" id $ getOptVal oopts useOptimizer
optim = takeWhile (/='_') optims
subs = drop 1 (dropWhile (/='_') optims) == "subs"
minfo1 <- return $
case optim of
"parametrize" -> shareModule paramOpt minfo0 -- parametrization and sharing
"values" -> shareModule valOpt minfo0 -- tables as courses-of-values
"share" -> shareModule shareOpt minfo0 -- sharing of branches
"all" -> shareModule allOpt minfo0 -- first parametrize then values
"none" -> minfo0 -- no optimization
_ -> shareModule shareOpt minfo0 -- sharing; default
-- do common subexpression elimination if required by flag "subs"
minfo' <-
if subs
then ioeErr $ elimSubtermsMod minfo1
else return minfo1
-- for resource, also emit gfr.
--- Also for incomplete, to create timestamped gfc/gfr files
case info of
ModMod m | emitsGFR m && emit && nomulti -> do
let rminfo = if isCompilable info
then subexpModule minfo
else (name, ModMod emptyModule)
let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo]))
putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out
_ -> return ()
let encode = case getOptVal opts uniCoding of
Just "utf8" -> encodeUTF8
_ -> id
(file,out) <- do
code <- return $ MkGFC.prCanonModInfo minfo'
return (gfcFile pname, encode code)
if emit && nomulti ---- && isCompilable info
then putp (" wrote file" +++ file) $ ioeIO $ writeFile file out
else putpp ("no need to save module" +++ prt name) $ return ()
return minfo'
where
putp = putPointE opts
putpp = putPointEsil opts
emitsGFR m = isModRes m ---- && isCompilable info
---- isModRes m || (isModCnc m && mstatus m == MSIncomplete)
isCompilable mi = case mi of
ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete
_ -> True
nomulti = not $ oElem makeMulti opts
emit = oElem emitCode opts && not (oElem notEmitCode opts)
-- for old GF: sort into modules, write files, compile as usual
compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar
compileOld opts file = do
let putp = putPointE opts
grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
files <- mapM writeNewGF $ modules grammar1
((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files
return grammar
writeNewGF :: SourceModule -> IOE FilePath
writeNewGF m@(i,_) = do
let file = gfFile $ prt i
ioeIO $ writeFile file $ prGrammar (MGrammar [m])
ioeIO $ putStrLn $ "wrote file" +++ file
return file
--- this function duplicates a lot of code from compileModule.
--- It does not really belong here either.
-- It selects those .gfe files that a grammar depends on and that
-- are younger than corresponding gf
getGFEFiles :: Options -> FilePath -> IO [FilePath]
getGFEFiles opts1 file = useIOE [] $ do
opts0 <- ioeIO $ getOptionsFromFile file
let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
let opts = addOptions opts1 opts0
let fpath = dropFileName file
ps0 <- ioeIO $ pathListOpts opts fpath
let ps1 = if (useFileOpt && not useLineOpt)
then (map (combine fpath) ps0)
else ps0
ps <- ioeIO $ extendPathEnv ps1
let file' = if useFileOpt then takeFileName file else file -- to find file itself
files <- getAllFiles opts ps [] file'
efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files]
es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf
return $ filter ((=='e') . last) es

477
src-3.0/GF/Compile/Evaluate.hs
View File

@@ -1,477 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Evaluate
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/01 15:39:12 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
-- Computation of source terms. Used in compilation and in @cc@ command.
-----------------------------------------------------------------------------
module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Data.Str
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Infra.Option
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Refresh
import GF.Grammar.PatternMatch
import GF.Grammar.Lockfield (isLockLabel) ----
import GF.Grammar.AppPredefined
import qualified Data.Map as Map
import Data.List (nub,intersperse)
import Control.Monad (liftM2, liftM)
import Debug.Trace
data EEnv = EEnv {
computd :: Map.Map (Ident,Ident) FTerm,
temp :: Int
}
emptyEEnv = EEnv Map.empty 0
lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm)
lookupComputed mc = do
env <- readSTM
return $ Map.lookup mc $ computd env
updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv ()
updateComputed mc t =
updateSTM (\e -> e{computd = Map.insert mc t (computd e)})
getTemp :: STM EEnv Ident
getTemp = do
env <- readSTM
updateSTM (\e -> e{temp = temp e + 1})
return $ identC ("#" ++ show (temp env))
data FTerm =
FTC Term
| FTF (Term -> FTerm)
prFTerm :: Integer -> FTerm -> String
prFTerm i t = case t of
FTC t -> prt t
FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i))
term2fterm t = case t of
Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b))
_ -> FTC t
traceFTerm c ft = ft ----
----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft
fterm2term :: FTerm -> STM EEnv Term
fterm2term t = case t of
FTC t -> return t
FTF f -> do
x <- getTemp
b <- fterm2term $ f (Vr x)
return $ Abs x b
subst g t = case t of
Vr x -> maybe t id $ lookup x g
_ -> composSafeOp (subst g) t
appFTerm :: FTerm -> [Term] -> FTerm
appFTerm ft ts = case (ft,ts) of
(FTF f, x:xs) -> appFTerm (f x) xs
(FTC c, _:_) -> FTC $ foldl App c ts
_ -> ft
apps :: Term -> (Term,[Term])
apps t = case t of
App f a -> (f',xs ++ [a]) where (f',xs) = apps f
_ -> (t,[])
appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env
evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info)
evalConcrete gr mo = mapMTree evaldef mo where
evaldef (f,info) = case info of
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $
do
pde' <- case pde of
Yes de -> do
liftM yes $ pEval ty de
_ -> return pde
--- ppr' <- liftM yes $ evalPrintname gr c ppr pde'
return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed
_ -> return (f,info)
pEval (context,val) trm = do ---- errIn ("parteval" +++ prt_ trm) $ do
let
vars = map fst context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm3 <- recordExpand val trm1 >>= comp subst >>= recomp subst
return $ mkAbs vars trm3
---- temporary hack to ascertain full evaluation, because of bug in comp
recomp g t = if notReady t then comp g t else return t
notReady = not . null . redexes
redexes t = case t of
Q _ _ -> return [()]
_ -> collectOp redexes t
recordExpand typ trm = case unComputed typ of
RecType tys -> case trm of
FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
_ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
_ -> return trm
comp g t = case t of
Q (IC "Predef") _ -> return t ----trace ("\nPredef:\n" ++ prt t) $ return t
Q p c -> do
md <- lookupComputed (p,c)
case md of
Nothing -> do
d <- lookRes (p,c)
updateComputed (p,c) $ traceFTerm c $ term2fterm d
return d
Just d -> fterm2term d >>= comp g
App f a -> case apps t of
{- ----
(h@(QC p c),xs) -> do
xs' <- mapM (comp g) xs
case lookupValueIndex gr ty t of
Ok v -> return v
_ -> return t
-}
(h@(Q p c),xs) | p == IC "Predef" -> do
xs' <- mapM (comp g) xs
(t',b) <- stmErr $ appPredefined (foldl App h xs')
if b then return t' else comp g t'
(h@(Q p c),xs) -> do
xs' <- mapM (comp g) xs
md <- lookupComputed (p,c)
case md of
Just ft -> do
t <- fterm2term $ appFTerm ft xs'
comp g t
Nothing -> do
d <- lookRes (p,c)
let ft = traceFTerm c $ term2fterm d
updateComputed (p,c) ft
t' <- fterm2term $ appFTerm ft xs'
comp g t'
_ -> do
f' <- comp g f
a' <- comp g a
case (f',a') of
(Abs x b,_) -> comp (ext x a' g) b
(QC _ _,_) -> returnC $ App f' a'
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
(_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
(Alias _ _ d, _) -> comp g (App d a')
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
_ -> do
(t',b) <- stmErr $ appPredefined (App f' a')
if b then return t' else comp g t'
Vr x -> do
t' <- maybe (prtRaise (
"context" +++ show g +++ ": no value given to variable") x) return $ lookup x g
case t' of
_ | t == t' -> return t
_ -> comp g t'
Abs x b -> do
b' <- comp (ext x (Vr x) g) b
return $ Abs x b'
Let (x,(_,a)) b -> do
a' <- comp g a
comp (ext x a' g) b
Prod x a b -> do
a' <- comp g a
b' <- comp (ext x (Vr x) g) b
return $ Prod x a' b'
P t l | isLockLabel l -> return $ R []
---- a workaround 18/2/2005: take this away and find the reason
---- why earlier compilation destroys the lock field
P t l -> do
t' <- comp g t
case t' of
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
R r -> maybe
(prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $
lookup l r
ExtR a (R b) -> case lookup l b of ----comp g (P (R b) l) of
Just (_,v) -> comp g v
_ -> comp g (P a l)
ExtR (R a) b -> case lookup l a of ----comp g (P (R b) l) of
Just (_,v) -> comp g v
_ -> comp g (P b l)
S (T i cs) e -> prawitz g i (flip P l) cs e
_ -> returnC $ P t' l
S t@(T _ cc) v -> do
v' <- comp g v
case v' of
FV vs -> do
ts' <- mapM (comp g . S t) vs
return $ variants ts'
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
_ -> do
t' <- comp g t
return $ S t' v' -- if v' is not canonical
S t v -> do
t' <- comp g t
v' <- comp g v
case t' of
T _ [(PV IW,c)] -> comp g c --- an optimization
T _ [(PT _ (PV IW),c)] -> comp g c
T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
V ptyp ts -> do
vs <- stmErr $ allParamValues gr ptyp
ps <- stmErr $ mapM term2patt vs
let cc = zip ps ts
case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical
T _ cc -> case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical
Alias _ _ d -> comp g (S d v')
S (T i cs) e -> prawitz g i (flip S v') cs e
_ -> returnC $ S t' v'
-- normalize away empty tokens
K "" -> return Empty
-- glue if you can
Glue x0 y0 -> do
x <- comp g x0
y <- comp g y0
case (x,y) of
(Alias _ _ d, y) -> comp g $ Glue d y
(x, Alias _ _ d) -> comp g $ Glue x d
(S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
(s, S (T i cs) e) -> prawitz g i (Glue s) cs e
(_,Empty) -> return x
(Empty,_) -> return y
(K a, K b) -> return $ K (a ++ b)
(_, Alts (d,vs)) -> do
---- (K a, Alts (d,vs)) -> do
let glx = Glue x
comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
(Alts _, ka) -> checks [do
y' <- stmErr $ strsFromTerm ka
---- (Alts _, K a) -> checks [do
x' <- stmErr $ strsFromTerm x -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
,return $ Glue x y
]
(FV ks,_) -> do
kys <- mapM (comp g . flip Glue y) ks
return $ variants kys
(_,FV ks) -> do
xks <- mapM (comp g . Glue x) ks
return $ variants xks
_ -> do
mapM_ checkNoArgVars [x,y]
r <- composOp (comp g) t
returnC r
Alts _ -> do
r <- composOp (comp g) t
returnC r
-- remove empty
C a b -> do
a' <- comp g a
b' <- comp g b
case (a',b') of
(Alts _, K a) -> checks [do
as <- stmErr $ strsFromTerm a' -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
,
return $ C a' b'
]
(Empty,_) -> returnC b'
(_,Empty) -> returnC a'
_ -> returnC $ C a' b'
-- reduce free variation as much as you can
FV ts -> mapM (comp g) ts >>= returnC . variants
-- merge record extensions if you can
ExtR r s -> do
r' <- comp g r
s' <- comp g s
case (r',s') of
(Alias _ _ d, _) -> comp g $ ExtR d s'
(_, Alias _ _ d) -> comp g $ Glue r' d
(R rs, R ss) -> stmErr $ plusRecord r' s'
(RecType rs, RecType ss) -> stmErr $ plusRecType r' s'
(_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss]
_ -> return $ ExtR r' s'
-- case-expand tables
-- if already expanded, don't expand again
T i@(TComp _) cs -> do
-- if there are no variables, don't even go inside
cs' <- {-if (null g) then return cs else-} mapPairsM (comp g) cs
return $ T i cs'
--- this means some extra work; should implement TSh directly
TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
T i cs -> do
pty0 <- stmErr $ getTableType i
ptyp <- comp g pty0
case allParamValues gr ptyp of
Ok vs -> do
cs' <- mapM (compBranchOpt g) cs
sts <- stmErr $ mapM (matchPattern cs') vs
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- stmErr $ mapM term2patt vs
let ps' = ps --- PT ptyp (head ps) : tail ps
return $ --- V ptyp ts -- to save space, just course of values
T (TComp ptyp) (zip ps' ts)
_ -> do
cs' <- mapM (compBranch g) cs
return $ T i cs' -- happens with variable types
-- otherwise go ahead
_ -> composOp (comp g) t >>= returnC
lookRes (p,c) = case lookupResDefKind gr p c of
Ok (t,_) | noExpand p -> return t
Ok (t,0) -> comp [] t
Ok (t,_) -> return t
Bad s -> raise s
noExpand p = errVal False $ do
mo <- lookupModMod gr p
return $ case getOptVal (iOpts (flags mo)) useOptimizer of
Just "noexpand" -> True
_ -> False
prtRaise s t = raise (s +++ prt t)
ext x a g = (x,a):g
returnC = return --- . computed
variants ts = case nub ts of
[t] -> t
ts -> FV ts
isCan v = case v of
Con _ -> True
QC _ _ -> True
App f a -> isCan f && isCan a
R rs -> all (isCan . snd . snd) rs
_ -> False
compBranch g (p,v) = do
let g' = contP p ++ g
v' <- comp g' v
return (p,v')
compBranchOpt g c@(p,v) = case contP p of
[] -> return c
_ -> compBranch g c
---- _ -> err (const (return c)) return $ compBranch g c
contP p = case p of
PV x -> [(x,Vr x)]
PC _ ps -> concatMap contP ps
PP _ _ ps -> concatMap contP ps
PT _ p -> contP p
PR rs -> concatMap (contP . snd) rs
PAs x p -> (x,Vr x) : contP p
PSeq p q -> concatMap contP [p,q]
PAlt p q -> concatMap contP [p,q]
PRep p -> contP p
PNeg p -> contP p
_ -> []
prawitz g i f cs e = do
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
return $ S (T i cs') e
-- | argument variables cannot be glued
checkNoArgVars :: Term -> STM EEnv Term
checkNoArgVars t = case t of
Vr (IA _) -> raise $ glueErrorMsg $ prt t
Vr (IAV _) -> raise $ glueErrorMsg $ prt t
_ -> composOp checkNoArgVars t
glueErrorMsg s =
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
"Use Prelude.bind instead."
stmErr :: Err a -> STM s a
stmErr e = stm (\s -> do
v <- e
return (v,s)
)
evalIn :: String -> STM s a -> STM s a
evalIn msg st = stm $ \s -> case appSTM st s of
Bad e -> Bad $ msg ++++ e
Ok vs -> Ok vs

92
src-3.0/GF/Compile/Flatten.hs
View File

@@ -1,92 +0,0 @@
module Flatten where
import Data.List
-- import GF.Data.Operations
-- (AR 15/3/2006)
--
-- A method for flattening grammars: create many flat rules instead of
-- a few deep ones. This is generally better for parsins.
-- The rules are obtained as follows:
-- 1. write a config file tellinq which constants are variables: format 'c : C'
-- 2. generate a list of trees with their types: format 't : T'
-- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin
-- rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as
-- found in the config file.
-- 4. You can go on and produce def or transfer rules similar to the lin rules
-- except for the keyword.
--
-- So far this module is used outside gf. You can e.g. generate a list of
-- trees by 'gt', write it in a file, and then in ghci call
-- flattenGrammar <Config> <Trees> <OutFile>
type Ident = String ---
type Term = String ---
type Rule = String ---
type Config = [(Ident,Ident)]
flattenGrammar :: FilePath -> FilePath -> FilePath -> IO ()
flattenGrammar conff tf out = do
conf <- readFile conff >>= return . lines
ts <- readFile tf >>= return . lines
writeFile out $ mkFlatten conf ts
mkFlatten :: [String] -> [String] -> String
mkFlatten conff = unlines . concatMap getOne . zip [1..] where
getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y]
conf = getConfig conff
mkRules :: Config -> Ident -> Term -> (Rule,Rule)
mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
args = mkArgs conf ts
ty = concat [a ++ " -> " | a <- map snd args] ++ val
(ts,val) = let tt = lexTerm t in (init tt,last tt)
--- f = identV t
fun c a = unwords [" fun", c, ":",a,";"]
lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"]
mkArgs :: Config -> [Ident] -> [(Ident,Ident)]
mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]]
mkIdent :: Term -> Ident
mkIdent = map mkChar where
mkChar c = case c of
'(' -> '6'
')' -> '9'
' ' -> '_'
_ -> c
-- to get just the identifiers
lexTerm :: String -> [String]
lexTerm ss = case lex ss of
[([c],ws)] | isSpec c -> lexTerm ws
[(w@(_:_),ws)] -> w : lexTerm ws
_ -> []
where
isSpec = flip elem "();:"
getConfig :: [String] -> Config
getConfig = map getOne . filter (not . null) where
getOne line = case lexTerm line of
v:c:_ -> (v,c)
ex = putStrLn fs where
fs =
mkFlatten
["man_N : N",
"sleep_V : V"
]
["PredVP (DefSg man_N) (UseV sleep_V) : Cl",
"PredVP (DefPl man_N) (UseV sleep_V) : Cl"
]
{-
-- result of ex
fun fu1 : N -> V -> Cl ;
lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V) ;
fun fu2 : N -> V -> Cl ;
lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V) ;
-}

146
src-3.0/GF/Compile/GetGrammar.hs
View File

@@ -1,146 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GetGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/15 17:56:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- this module builds the internal GF grammar that is sent to the type checker
-----------------------------------------------------------------------------
module GF.Compile.GetGrammar (
getSourceModule, getSourceGrammar,
getOldGrammar, getCFGrammar, getEBNFGrammar
) where
import GF.Data.Operations
import qualified GF.Source.ErrM as E
import GF.Infra.UseIO
import GF.Grammar.Grammar
import GF.Infra.Modules
import GF.Grammar.PrGrammar
import qualified GF.Source.AbsGF as A
import GF.Source.SourceToGrammar
---- import Macros
---- import Rename
import GF.Text.UTF8 ----
import GF.Infra.Option
--- import Custom
import GF.Source.ParGF
import qualified GF.Source.LexGF as L
import GF.CF.CF (rules2CF)
import GF.CF.PPrCF
import GF.CF.CFtoGrammar
import GF.CF.EBNF
import GF.Infra.ReadFiles ----
import Data.Char (toUpper)
import Data.List (nub)
import qualified Data.ByteString.Char8 as BS
import Control.Monad (foldM)
import System (system)
import System.FilePath
getSourceModule :: Options -> FilePath -> IOE SourceModule
getSourceModule opts file0 = do
file <- case getOptVal opts usePreprocessor of
Just p -> do
let tmp = "_gf_preproc.tmp"
cmd = p +++ file0 ++ ">" ++ tmp
ioeIO $ system cmd
-- ioeIO $ putStrLn $ "preproc" +++ cmd
return tmp
_ -> return file0
string0 <- readFileIOE file
let string = case getOptVal opts uniCoding of
Just "utf8" -> decodeUTF8 string0
_ -> string0
let tokens = myLexer (BS.pack string)
mo1 <- ioeErr $ pModDef tokens
ioeErr $ transModDef mo1
getSourceGrammar :: Options -> FilePath -> IOE SourceGrammar
getSourceGrammar opts file = do
string <- readFileIOE file
let tokens = myLexer (BS.pack string)
gr1 <- ioeErr $ pGrammar tokens
ioeErr $ transGrammar gr1
-- for old GF format with includes
getOldGrammar :: Options -> FilePath -> IOE SourceGrammar
getOldGrammar opts file = do
defs <- parseOldGrammarFiles file
let g = A.OldGr A.NoIncl defs
let name = takeFileName file
ioeErr $ transOldGrammar opts name g
parseOldGrammarFiles :: FilePath -> IOE [A.TopDef]
parseOldGrammarFiles file = do
putStrLnE $ "reading grammar of old format" +++ file
(_, g) <- getImports "" ([],[]) file
return g -- now we can throw away includes
where
getImports oldInitPath (oldImps, oldG) f = do
(path,s) <- readFileLibraryIOE oldInitPath f
if not (elem path oldImps)
then do
(imps,g) <- parseOldGrammar path
foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps
else
return (oldImps, oldG)
parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef])
parseOldGrammar file = do
putStrLnE $ "reading old file" +++ file
s <- ioeIO $ readFileIf file
A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s
includes <- ioeErr $ transInclude incl
return (includes, topdefs)
----
-- | To resolve the new reserved words:
-- change them by turning the final letter to upper case.
--- There is a risk of clash.
oldLexer :: String -> [L.Token]
oldLexer = map change . L.tokens . BS.pack where
change t = case t of
(L.PT p (L.TS s)) | elem s newReservedWords ->
(L.PT p (L.TV (init s ++ [toUpper (last s)])))
_ -> t
getCFGrammar :: Options -> FilePath -> IOE SourceGrammar
getCFGrammar opts file = do
let mo = takeWhile (/='.') file
s <- ioeIO $ readFileIf file
let files = case words (concat (take 1 (lines s))) of
"--":"include":fs -> fs
_ -> []
ss <- ioeIO $ mapM readFileIf files
cfs <- ioeErr $ mapM (pCF mo) $ s:ss
defs <- return $ cf2grammar $ rules2CF $ concat cfs
let g = A.OldGr A.NoIncl defs
--- let ma = justModuleName file
--- let mc = 'C':ma ---
--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
ioeErr $ transOldGrammar opts file g
getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar
getEBNFGrammar opts file = do
let mo = takeWhile (/='.') file
s <- ioeIO $ readFileIf file
defs <- ioeErr $ pEBNFasGrammar s
let g = A.OldGr A.NoIncl defs
--- let ma = justModuleName file
--- let mc = 'C':ma ---
--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
ioeErr $ transOldGrammar opts file g

293
src-3.0/GF/Compile/GrammarToCanon.hs
View File

@@ -1,293 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GrammarToCanon
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:33 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.23 $
--
-- Code generator from optimized GF source code to GFC.
-----------------------------------------------------------------------------
module GF.Compile.GrammarToCanon (showGFC,
redModInfo, redQIdent
) where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Infra.Option
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Grammar.Macros
import qualified GF.Canon.AbsGFC as G
import qualified GF.Canon.GFC as C
import GF.Canon.MkGFC
---- import Alias
import qualified GF.Canon.PrintGFC as P
import Control.Monad
import Data.List (nub,sortBy)
-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
-- | This is the top-level function printing a gfc file
showGFC :: SourceGrammar -> String
showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
-- | any grammar, first trying without dependent types
-- abstract syntax without dependent types
redGrammar :: SourceGrammar -> Err C.CanonGrammar
redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
active (_,m) = case typeOfModule m of
MTInterface -> False
_ -> True
redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
redModInfo (c,info) = do
c' <- redIdent c
info' <- case info of
ModMod m -> do
let isIncompl = not $ isCompleteModule m
(e,os) <- if isIncompl then return ([],[]) else redExtOpen m ----
flags <- mapM redFlag $ flags m
(a,mt0) <- case mtype m of
MTConcrete a -> do
a' <- redIdent a
return (a', MTConcrete a')
MTAbstract -> return (c',MTAbstract) --- c' not needed
MTResource -> return (c',MTResource) --- c' not needed
MTInterface -> return (c',MTResource) ---- not needed
MTInstance _ -> return (c',MTResource) --- c' not needed
MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
--- this generates empty GFC reosurce for interface and incomplete
let js = if isIncompl then emptyBinTree else jments m
mt = mt0 ---- if isIncompl then MTResource else mt0
defss <- mapM (redInfo a) $ tree2list $ js
let defs0 = concat defss
let lgh = length defs0
defs <- return $ sorted2tree $ defs0 -- sorted, but reduced
let flags1 = if isIncompl then C.flagIncomplete : flags else flags
let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1
return $ ModMod $ Module mt MSComplete flags' e os defs
return (c',info')
where
redExtOpen m = do
e' <- case extends m of
es -> mapM (liftM inheritAll . redIdent) es
os' <- mapM (\o -> case o of
OQualif q _ i -> liftM (OSimple q) (redIdent i)
_ -> prtBad "cannot translate unqualified open in" c) $ opens m
return (e',nub os')
om = oSimple . openedModule --- normalizing away qualif
redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
c' <- redIdent c
case info of
AbsCat (Yes cont) pfs -> do
let fs = case pfs of
Yes ts -> [(m,c) | Q m c <- ts]
_ -> []
returns c' $ C.AbsCat cont fs
AbsFun (Yes typ) pdf -> do
let df = case pdf of
Yes t -> t -- definition or "data"
_ -> Eqs [] -- primitive notion
returns c' $ C.AbsFun typ df
AbsTrans t ->
returns c' $ C.AbsTrans t
ResParam (Yes (ps,_)) -> do
ps' <- mapM redParam ps
returns c' $ C.ResPar ps'
CncCat pty ptr ppr -> case (pty,ptr,ppr) of
(Yes ty, Yes (Abs _ t), Yes pr) -> do
ty' <- redCType ty
trm' <- redCTerm t
pr' <- redCTerm pr
return [(c', C.CncCat ty' trm' pr')]
_ -> prtBad ("cannot reduce rule for") c
CncFun mt ptr ppr -> case (mt,ptr,ppr) of
(Just (cat,_), Yes trm, Yes pr) -> do
cat' <- redIdent cat
(xx,body,_) <- termForm trm
xx' <- mapM redArgvar xx
body' <- errIn (prt body) $ redCTerm body ---- debug
pr' <- redCTerm pr
return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')]
_ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
AnyInd s b -> do
b' <- redIdent b
returns c' $ C.AnyInd s b'
_ -> return [] --- retain some operations
where
returns f i = return [(f,i)]
redQIdent :: QIdent -> Err G.CIdent
redQIdent (m,c) = return $ G.CIQ m c
redIdent :: Ident -> Err Ident
redIdent x
| isWildIdent x = return $ identC "h_" --- needed in declarations
| otherwise = return $ identC $ prt x ---
redFlag :: Option -> Err G.Flag
redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x)
redFlag o = Bad $ "cannot reduce option" +++ prOpt o
redDecl :: Decl -> Err G.Decl
redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a)
redType :: Type -> Err G.Exp
redType = redTerm
redTerm :: Type -> Err G.Exp
redTerm t = return $ rtExp t
-- to normalize records and record types
sortByFst :: Ord a => [(a,b)] -> [(a,b)]
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
-- resource
redParam :: Param -> Err G.ParDef
redParam (c,cont) = do
c' <- redIdent c
cont' <- mapM (redCType . snd) cont
return $ G.ParD c' cont'
redArgvar :: Ident -> Err G.ArgVar
redArgvar x = case x of
IA (x,i) -> return $ G.A (identC x) (toInteger i)
IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i)
_ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable"
redLindef :: Term -> Err G.Term
redLindef t = case t of
Abs x b -> redCTerm b ---
_ -> redCTerm t
redCType :: Type -> Err G.CType
redCType t = case t of
RecType lbs -> do
let (ls,ts) = unzip lbs
ls' = map redLabel ls
ts' <- mapM redCType ts
return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts'
Table p v -> liftM2 G.Table (redCType p) (redCType v)
Q m c -> liftM G.Cn $ redQIdent (m,c)
QC m c -> liftM G.Cn $ redQIdent (m,c)
App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return $ G.TInts (toInteger n)
Sort "Str" -> return $ G.TStr
Sort "Tok" -> return $ G.TStr
_ -> prtBad "cannot reduce to canonical the type" t
redCTerm :: Term -> Err G.Term
redCTerm t = case t of
Vr x -> checkAgain
(liftM G.Arg $ redArgvar x)
(liftM G.LI $ redIdent x) --- for parametrize optimization
App _ s -> do -- only constructor applications can remain
(_,c,xx) <- termForm t
xx' <- mapM redCTerm xx
case c of
QC p c -> liftM2 G.Par (redQIdent (p,c)) (return xx')
Q (IC "Predef") (IC "error") -> fail $ "error: " ++ stringFromTerm s
_ -> prtBad "expected constructor head instead of" c
Q p c -> liftM G.I (redQIdent (p,c))
QC p c -> liftM2 G.Par (redQIdent (p,c)) (return [])
R rs -> do
let (ls,tts) = unzip rs
ls' = map redLabel ls
ts <- mapM (redCTerm . snd) tts
return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts
RecType [] -> return $ G.R [] --- comes out in parsing
P tr l -> do
tr' <- redCTerm tr
return $ G.P tr' (redLabel l)
PI tr l _ -> redCTerm $ P tr l -----
T i cs -> do
ty <- getTableType i
ty' <- redCType ty
let (ps,ts) = unzip cs
ps' <- mapM redPatt ps
ts' <- mapM redCTerm ts
return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
TSh i cs -> do
ty <- getTableType i
ty' <- redCType ty
let (pss,ts) = unzip cs
pss' <- mapM (mapM redPatt) pss
ts' <- mapM redCTerm ts
return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts'
V ty ts -> do
ty' <- redCType ty
ts' <- mapM redCTerm ts
return $ G.V ty' ts'
S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
K s -> return $ G.K (G.KS s)
EInt i -> return $ G.EInt i
EFloat i -> return $ G.EFloat i
C u v -> liftM2 G.C (redCTerm u) (redCTerm v)
FV ts -> liftM G.FV $ mapM redCTerm ts
--- Ready ss -> return $ G.Ready [redStr ss] --- obsolete
Alts (d,vs) -> do ---
d' <- redCTermTok d
vs' <- mapM redVariant vs
return $ G.K $ G.KP d' vs'
Empty -> return $ G.E
--- Strs ss -> return $ G.Strs [s | K s <- ss] ---
---- Glue obsolete in canon, should not occur here
Glue x y -> redCTerm (C x y)
_ -> Bad ("cannot reduce term" +++ prt t)
redPatt :: Patt -> Err G.Patt
redPatt p = case p of
PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps)
PR rs -> do
let (ls,tts) = unzip rs
ls' = map redLabel ls
ts <- mapM redPatt tts
return $ G.PR $ map (uncurry G.PAss) $ sortByFst $ zip ls' ts
PT _ q -> redPatt q
PInt i -> return $ G.PI i
PFloat i -> return $ G.PF i
PV x -> liftM G.PV $ redIdent x --- for parametrize optimization
_ -> prtBad "cannot reduce pattern" p
redLabel :: Label -> G.Label
redLabel (LIdent s) = G.L $ identC s
redLabel (LVar i) = G.LV $ toInteger i
redVariant :: (Term, Term) -> Err G.Variant
redVariant (v,c) = do
v' <- redCTermTok v
c' <- redCTermTok c
return $ G.Var v' c'
redCTermTok :: Term -> Err [String]
redCTermTok t = case t of
K s -> return [s]
Empty -> return []
C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b)
Strs ss -> return [s | K s <- ss] ---
_ -> prtBad "cannot get strings from term" t

154
src-3.0/GF/Compile/MkConcrete.hs
View File

@@ -1,154 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MkConcrete
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date:
-- > CVS $Author:
-- > CVS $Revision:
--
-- Compile a gfe file into a concrete syntax by using the parser on a resource grammar.
-----------------------------------------------------------------------------
module GF.Compile.MkConcrete (mkConcretes) where
import GF.Grammar.Values (Tree,tree2exp)
import GF.Grammar.PrGrammar (prt_,prModule)
import GF.Grammar.Grammar --- (Term(..),SourceModule)
import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent)
import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords)
import GF.Compile.PGrammar (pTerm,pTrm)
import GF.Compile.Compile
import GF.Compile.PrOld (stripTerm)
import GF.Compile.GetGrammar
import GF.API
import GF.API.IOGrammar
import qualified GF.Embed.EmbedAPI as EA
import GF.Data.Operations
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Infra.Modules
import GF.Infra.ReadFiles
import GF.System.Arch
import GF.UseGrammar.Treebank
import System.Directory
import System.FilePath
import Data.Char
import Control.Monad
import Data.List
-- translate strings into lin rules by parsing in a resource
-- grammar. AR 2/6/2005
-- Format of rule (on one line):
-- lin F x y = in C "ssss" ;
-- Format of resource path (on first line):
-- --# -resource=PATH
-- Other lines are copied verbatim.
-- A sequence of files can be processed with the same resource without
-- rebuilding the grammar and parser.
-- notice: we use a hand-crafted lexer and parser in order to preserve
-- the layout and comments in the rest of the file.
mkConcretes :: Options -> [FilePath] -> IO ()
mkConcretes opts files = do
ress <- mapM getResPath files
let grps = groupBy (\a b -> fst a == fst b) $
sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files
mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps]
mkCncGroups opts0 ((res,path),files) = do
putStrLnFlush $ "Going to preprocess examples in " ++ unwords files
putStrLn $ "Compiling resource " ++ res
let opts = addOptions (options [beSilent,pathList path]) opts0
let treebank = oElem (iOpt "treebank") opts
resf <- useIOE res $ do
(fp,_) <- readFileLibraryIOE "" res
return fp
egr <- appIOE $ shellStateFromFiles opts emptyShellState resf
(parser,morpho) <- if treebank then do
tb <- err (\_ -> error $ "no treebank of name" +++ path)
return
(egr >>= flip findTreebank (zIdent path))
return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb,
isWordInTreebank tb)
else do
gr <- err (\s -> putStrLn s >> error "resource grammar rejected")
(return . firstStateGrammar) egr
return
(\cat s ->
errVal ([],"No parse") $
optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>=
(\ (ts,e) -> return (map tree2exp ts, e)) ,
isKnownWord gr)
putStrLn "Building parser"
mapM_ (mkConcrete parser morpho) files
type Parser = String -> String -> ([Term],String)
type Morpho = String -> Bool
getResPath :: FilePath -> IO (String,String)
getResPath file = do
s <- liftM lines $ readFileIf file
case filter (not . all isSpace) s of
res:path:_ | is "resource" res && is "path" path -> return (val res, val path)
res:path:_ | is "resource" res && is "treebank" path -> return (val res, val path)
res:_ | is "resource" res -> return (val res, "")
_ -> error
"expected --# -resource=FILE and optional --# -path=PATH or --# -treebank=IDENT"
where
val = dropWhile (isSpace) . tail . dropWhile (not . (=='='))
is tag s = case words s of
"--#":w:_ -> isPrefixOf ('-':tag) w
_ -> False
mkConcrete :: Parser -> Morpho -> FilePath -> IO ()
mkConcrete parser morpho file = do
src <- appIOE (getSourceModule noOptions file) >>= err error return
let (src',msgs) = mkModule parser morpho src
let out = addExtension (justModuleName file) "gf"
writeFile out $ "-- File generated by GF from " ++ file
appendFile out "\n"
appendFile out (prModule src')
appendFile out "{-\n"
appendFile out $ unlines $ filter (not . null) msgs
appendFile out "-}\n"
mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String])
mkModule parser morpho (name,src) = case src of
ModMod m@(Module mt st fs me ops js) ->
let js1 = jments m
(js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) []
mod2 = ModMod $ Module mt st fs me ops $ js2
in ((name,mod2), msgs)
where
mkInfo ni@(name,info) = case info of
CncFun mt (Yes trm) ppr -> do
trm' <- mkTrm trm
return (name, CncFun mt (Yes trm') ppr)
_ -> return ni
where
mkTrm t = case t of
Example (P _ cat) s -> parse cat s t
Example (Vr cat) s -> parse cat s t
_ -> composOp mkTrm t
parse cat s t = case parser (prt_ cat) s of
(tr:[], _) -> do
updateSTM ((("PARSED in" +++ prt_ name) : s : [prt_ tr]) ++)
return $ stripTerm tr
(tr:trs,_) -> do
updateSTM ((("AMBIGUOUS in" +++ prt_ name) : s : map prt_ trs) ++)
return $ stripTerm tr
([],ms) -> do
updateSTM ((("NO PARSE in" +++ prt_ name) : s : ms : [morph s]) ++)
return t
morph s = case [w | w <- words s, not (morpho w)] of
[] -> ""
ws -> "unknown words: " ++ unwords ws

128
src-3.0/GF/Compile/MkResource.hs
View File

@@ -1,128 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MkResource
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.14 $
--
-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
-----------------------------------------------------------------------------
module GF.Compile.MkResource (makeReuse) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Lockfield
import GF.Grammar.PrGrammar
import GF.Data.Operations
import Control.Monad
-- | extracting resource r from abstract + concrete syntax.
-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules
makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] ->
MReuseType Ident -> Err SourceRes
makeReuse gr r me mrc = do
flags <- return [] --- no flags are passed: they would not make sense
case mrc of
MRResource c -> do
(ops,jms) <- mkFull True c
return $ Module MTResource MSComplete flags me ops jms
MRInstance c a -> do
(ops,jms) <- mkFull False c
return $ Module (MTInstance a) MSComplete flags me ops jms
MRInterface c -> do
mc <- lookupModule gr c
(ops,jms) <- case mc of
ModMod m -> case mtype m of
MTAbstract -> liftM ((,) (opens m)) $
mkResDefs True False gr r c me
(extend m) (jments m) emptyBinTree
_ -> prtBad "expected abstract to be the type of" c
_ -> prtBad "expected abstract to be the type of" c
return $ Module MTInterface MSIncomplete flags me ops jms
where
mkFull hasT c = do
mc <- lookupModule gr c
case mc of
ModMod m -> case mtype m of
MTConcrete a -> do
ma <- lookupModule gr a
jmsA <- case ma of
ModMod m' -> return $ jments m'
_ -> prtBad "expected abstract to be the type of" a
liftM ((,) (opens m)) $
mkResDefs hasT True gr r a me (extend m) jmsA (jments m)
_ -> prtBad "expected concrete to be the type of" c
_ -> prtBad "expected concrete to be the type of" c
-- | the first Boolean indicates if the type needs be given
-- the second Boolean indicates if the definition needs be given
mkResDefs :: Bool -> Bool ->
SourceGrammar -> Ident -> Ident ->
[(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] ->
BinTree Ident Info -> BinTree Ident Info ->
Err (BinTree Ident Info)
mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
ifTyped = yes --- if hasT then yes else const nope --- needed for TC
ifCompl = if isC then yes else const nope
doIf b t = if b then t else return typeType -- latter value not used
mkOne a mae (f,info) = case info of
AbsCat _ _ -> do
typ <- doIf isC $ err (const (return defLinType)) return $ look cnc f
typ' <- doIf isC $ lockRecType f typ
return (f, ResOper (ifTyped typeType) (ifCompl typ'))
AbsFun (Yes typ0) _ -> do
trm <- doIf isC $ look cnc f
testErr (not (isHardType typ0))
("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
typ <- redirTyp True a mae typ0
cat <- valCat typ
trm' <- doIf isC $ unlockRecord (snd cat) trm
return (f, ResOper (ifTyped typ) (ifCompl trm'))
AnyInd b n -> do
mo <- lookupModMod gr n
info' <- lookupInfo mo f
mkOne n (extend mo) (f,info')
look cnc f = do
info <- lookupTree prt f cnc
case info of
CncCat (Yes ty) _ _ -> return ty
CncCat _ _ _ -> return defLinType
CncFun _ (Yes tr) _ -> return tr
AnyInd _ n -> do
mo <- lookupModMod gr n
t <- look (jments mo) f
redirTyp False n (extend mo) t
_ -> prtBad "not enough information to reuse" f
-- type constant qualifications changed from abstract to resource
redirTyp always a mae ty = case ty of
Q _ c | always -> return $ Q r c
Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts
_ -> composOp (redirTyp always a mae) ty
-- | no reuse for functions of HO\/dep types
isHardType t = case t of
Prod x a b -> not (isWild x) || isHardType a || isHardType b
App _ _ -> True
_ -> False
where
isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon

83
src-3.0/GF/Compile/MkUnion.hs
View File

@@ -1,83 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MkUnion
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:39 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- building union of modules.
-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance
-----------------------------------------------------------------------------
module GF.Compile.MkUnion (makeUnion) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Data.Operations
import GF.Infra.Option
import Data.List
import Control.Monad
makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
Err SourceModule
makeUnion gr m ty imps = do
ms <- mapM (lookupModMod gr . fst) imps
typ <- return ty ---- getTyp ms
ext <- getExt [i | Just i <- map extends ms]
ops <- return $ nub $ concatMap opens ms
flags <- return $ concatMap flags ms
js <- liftM (buildTree . concat) $ mapM getJments imps
return $ (m, ModMod (Module typ MSComplete flags ext ops js))
where
getExt es = case es of
[] -> return Nothing
i:is -> if all (==i) is then return (Just i)
else Bad "different extended modules in union forbidden"
getJments (i,fs) = do
m <- lookupModMod gr i
let js = jments m
if null fs
then
return (map (unqual i) $ tree2list js)
else do
ds <- mapM (flip justLookupTree js) fs
return $ map (unqual i) $ zip fs ds
unqual i (f,d) = curry id f $ case d of
AbsCat pty pts -> AbsCat (qualCo pty) (qualPs pts)
AbsFun pty pt -> AbsFun (qualP pty) (qualP pt)
AbsTrans t -> AbsTrans $ qual t
ResOper pty pt -> ResOper (qualP pty) (qualP pt)
CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp)
CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
ResParam (Yes ps) -> ResParam (yes (map qualParam ps))
ResValue pty -> ResValue (qualP pty)
_ -> d
where
qualP pt = case pt of
Yes t -> yes $ qual t
_ -> pt
qualPs pt = case pt of
Yes ts -> yes $ map qual ts
_ -> pt
qualCo pco = case pco of
Yes co -> yes $ [(x,qual t) | (x,t) <- co]
_ -> pco
qual t = case t of
Q m c | m==i -> Cn c
QC m c | m==i -> Cn c
_ -> composSafeOp qual t
qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co])
qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
qualLin Nothing = Nothing

294
src-3.0/GF/Compile/NewRename.hs
View File

@@ -1,294 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:41 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- AR 14\/5\/2003
--
-- The top-level function 'renameGrammar' does several things:
--
-- - extends each module symbol table by indirections to extended module
--
-- - changes unqualified and as-qualified imports to absolutely qualified
--
-- - goes through the definitions and resolves names
--
-- Dependency analysis between modules has been performed before this pass.
-- Hence we can proceed by @fold@ing "from left to right".
-----------------------------------------------------------------------------
module GF.Compile.NewRename (renameSourceTerm, renameModule) where
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Infra.Modules
import GF.Infra.Ident
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Grammar.AppPredefined
import GF.Grammar.Lookup
import GF.Compile.Extend
import GF.Data.Operations
import Control.Monad
-- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
renameSourceTerm g m t = do
mo <- lookupErr m (modules g)
let status = (modules g,(m,mo)) --- <- buildStatus g m mo
renameTerm status [] t
-- | this is used in the compiler, separately for each module
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
ModMod m@(Module mt st fs me ops js) -> do
let js1 = jments m
let status = (ms, (name, mod))
js2 <- mapMTree (renameInfo status) js1
let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
return $ (name,mod2) : ms
type Status = ([SourceModule],SourceModule) --- (StatusTree, [(OpenSpec Ident, StatusTree)])
--- type StatusTree = BinTree (Ident,StatusInfo)
--- type StatusInfo = Ident -> Term
lookupStatusInfo :: Ident -> SourceModule -> Err Term
lookupStatusInfo c (q,ModMod m) = do
i <- lookupTree prt c $ jments m
return $ case i of
AbsFun _ (Yes EData) -> QC q c
ResValue _ -> QC q c
ResParam _ -> QC q c
AnyInd True n -> QC n c --- should go further?
AnyInd False n -> Q n c
_ -> Q q c
lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q
lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term
lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of
Ok v -> return v
_ -> lookupStatusInfoMany ms c
lookupStatusInfoMany [] x =
prtBad "renaming failed to find unqualified constant" x
---- should also give error if stg is found in more than one module
renameIdentTerm :: Status -> Term -> Err Term
renameIdentTerm env@(imps,act@(_,ModMod this)) t =
errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
case t of
Vr c -> do
f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c
return $ f
Cn c -> do
f <- lookupStatusInfoMany openeds c
return $ f
Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
Q m' c -> do
m <- lookupErr m' qualifs
f <- lookupStatusInfo c m
return $ f
QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
QC m' c -> do
m <- lookupErr m' qualifs
f <- lookupStatusInfo c m
return $ f
_ -> return t
where
openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
qualifs =
[(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]]
++
[(m, (m,st)) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
-- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s = case c of
IC "Int" -> return $ Q cPredefAbs cInt
IC "String" -> return $ Q cPredefAbs cString
_ -> Bad s
-- | would it make sense to optimize this by inlining?
renameIdentPatt :: Status -> Patt -> Err Patt
renameIdentPatt env p = do
let t = patt2term p
t' <- renameIdentTerm env t
term2patt t'
{- deprec !
info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
info2status mq (c,i) = (c, case i of
AbsFun _ (Yes EData) -> maybe Con QC mq
ResValue _ -> maybe Con QC mq
ResParam _ -> maybe Con QC mq
AnyInd True m -> maybe Con (const (QC m)) mq
AnyInd False m -> maybe Cn (const (Q m)) mq
_ -> maybe Cn Q mq
)
tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
tree2status o = case o of
OSimple _ i -> mapTree (info2status (Just i))
OQualif _ i j -> mapTree (info2status (Just j))
buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
buildStatus gr c mo = let mo' = self2status c mo in case mo of
ModMod m -> do
let gr1 = MGrammar $ (c,mo) : modules gr
ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m
mods <- mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return $ if isModCnc m
then (NT, reverse sts) -- the module itself does not define any names
else (mo',reverse sts) -- so the empty ident is not needed
modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
modInfo2status (o,i) = (o,case i of
ModMod m -> tree2status o (jments m)
)
self2status :: Ident -> SourceModInfo -> StatusTree
self2status c i = mapTree (info2status (Just c)) js where -- qualify internal
js = case i of
ModMod m
| isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m
| otherwise -> jments m
noTrans (_,d) = case d of -- to enable other than transfer js in transfer module
AbsTrans _ -> False
_ -> True
-}
forceQualif o = case o of
OSimple q i -> OQualif q i i
OQualif q _ i -> OQualif q i i
renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $
liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
AbsTrans f -> liftM AbsTrans (rent f)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
ResValue t -> liftM ResValue (ren t)
CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr)
_ -> return info
where
ren = renPerh rent
rent = renameTerm status []
renPerh ren pt = case pt of
Yes t -> liftM Yes $ ren t
_ -> return pt
renameTerm :: Status -> [Ident] -> Term -> Err Term
renameTerm env vars = ren vars where
ren vs trm = case trm of
Abs x b -> liftM (Abs x) (ren (x:vs) b)
Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
Vr x
| elem x vs -> return trm
| otherwise -> renid trm
Cn _ -> renid trm
Con _ -> renid trm
Q _ _ -> renid trm
QC _ _ -> renid trm
Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
T i cs -> do
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
_ -> return i
liftM (T i') $ mapM (renCase vs) cs
Let (x,(m,a)) b -> do
m' <- case m of
Just ty -> liftM Just $ ren vs ty
_ -> return m
a' <- ren vs a
b' <- ren (x:vs) b
return $ Let (x,(m',a')) b'
P t@(Vr r) l -- for constant t we know it is projection
| elem r vs -> return trm -- var proj first
| otherwise -> case renid (Q r (label2ident l)) of -- qualif second
Ok t -> return t
_ -> liftM (flip P l) $ renid t -- const proj last
_ -> composOp (ren vs) trm
renid = renameIdentTerm env
renCase vs (p,t) = do
(p',vs') <- renpatt p
t' <- ren (vs' ++ vs) t
return (p',t')
renpatt = renamePattern env
-- | vars not needed in env, since patterns always overshadow old vars
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
renamePattern env patt = case patt of
PC c ps -> do
c' <- renameIdentTerm env $ Cn c
psvss <- mapM renp ps
let (ps',vs) = unzip psvss
case c' of
QC p d -> return (PP p d ps', concat vs)
Q p d -> return (PP p d ps', concat vs) ---- should not happen
_ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
---- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps
PV x -> case renid patt of
Ok p -> return (p,[])
_ -> return (patt, [x])
PR r -> do
let (ls,ps) = unzip r
psvss <- mapM renp ps
let (ps',vs') = unzip psvss
return (PR (zip ls ps'), concat vs')
_ -> return (patt,[])
where
renp = renamePattern env
renid = renameIdentPatt env
renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
renameParam env (c,co) = do
co' <- renameContext env co
return (c,co')
renameContext :: Status -> Context -> Err Context
renameContext b = renc [] where
renc vs cont = case cont of
(x,t) : xts
| isWildIdent x -> do
t' <- ren vs t
xts' <- renc vs xts
return $ (x,t') : xts'
| otherwise -> do
t' <- ren vs t
let vs' = x:vs
xts' <- renc vs' xts
return $ (x,t') : xts'
_ -> return cont
ren = renameTerm b
-- | vars not needed in env, since patterns always overshadow old vars
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
renameEquation b vs (ps,t) = do
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
t' <- renameTerm b (concat vs' ++ vs) t
return (ps',t')

49
src-3.0/GF/Compile/NoParse.hs
View File

@@ -1,49 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : NoParse
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:41 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.1 $
--
-- Probabilistic abstract syntax. AR 30\/10\/2005
--
-- (c) Aarne Ranta 2005 under GNU GPL
--
-- Contents: decide what lin rules no parser is generated.
-- Usually a list of noparse idents from 'i -boparse=file'.
-----------------------------------------------------------------------------
module GF.Compile.NoParse (
NoParse -- = Ident -> Bool
,getNoparseFromFile -- :: Opts -> IO NoParse
,doParseAll -- :: NoParse
) where
import GF.Infra.Ident
import GF.Data.Operations
import GF.Infra.Option
type NoParse = (Ident -> Bool)
doParseAll :: NoParse
doParseAll = const False
getNoparseFromFile :: Options -> FilePath -> IO NoParse
getNoparseFromFile opts file = do
let f = maybe file id $ getOptVal opts noparseFile
s <- readFile f
let tree = buildTree $ flip zip (repeat ()) $ concat $ map getIgnores $ lines s
tree `seq` return $ igns tree
where
igns tree i = isInBinTree i tree
-- where
getIgnores s = case dropWhile (/="--#") (words s) of
_:"noparse":fs -> map identC fs
_ -> []

300
src-3.0/GF/Compile/Optimize.hs
View File

@@ -1,300 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Optimize
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/16 13:56:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.18 $
--
-- Top-level partial evaluation for GF source modules.
-----------------------------------------------------------------------------
module GF.Compile.Optimize (optimizeModule) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.PrGrammar
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Refresh
import GF.Grammar.Compute
import GF.Compile.BackOpt
import GF.Compile.CheckGrammar
import GF.Compile.Update
import GF.Compile.Evaluate
import GF.Data.Operations
import GF.Infra.CheckM
import GF.Infra.Option
import Control.Monad
import Data.List
import Debug.Trace
-- conditional trace
prtIf :: (Print a) => Bool -> a -> a
prtIf b t = if b then trace (" " ++ prt t) t else t
-- experimental evaluation, option to import
oEval = iOpt "eval"
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-- only do this for resource: concrete is optimized in gfc form
optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
ModMod m0@(Module mt st fs me ops js) |
st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
(mo1,_) <- evalModule oopts mse mo
let
mo2 = case optim of
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
"values" -> shareModule valOpt mo1 -- tables as courses-of-values
"share" -> shareModule shareOpt mo1 -- sharing of branches
"all" -> shareModule allOpt mo1 -- first parametrize then values
"none" -> mo1 -- no optimization
_ -> mo1 -- none; default for src
return (mo2,eenv)
_ -> evalModule oopts mse mo
where
oopts = addOptions opts (iOpts (flagsModule mo))
optim = maybe "all" id $ getOptVal oopts useOptimizer
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
Err ((Ident,SourceModInfo),EEnv)
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
_ | isModRes m0 && not (oElem oEval oopts) -> do
let deps = allOperDependencies name js
ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids
return $ (mod',eenv)
MTConcrete a | oElem oEval oopts -> do
(js0,eenv') <- appEvalConcrete gr js eenv
js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005
return $ ((name, ModMod (Module mt st fs me ops js')),eenv')
MTConcrete a -> do
js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
return $ ((name, ModMod (Module mt st fs me ops js')),eenv)
_ -> return $ ((name,mod),eenv)
_ -> return $ ((name,mod),eenv)
where
gr0 = MGrammar $ ms
gr = MGrammar $ (name,mod) : ms
evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
info <- lookupTree prt i $ jments m
info' <- evalResInfo oopts gr (i,info)
return $ updateRes g name i info'
-- | only operations need be compiled in a resource, and this is local to each
-- definition since the module is traversed in topological order
evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
evalResInfo oopts gr (c,info) = case info of
ResOper pty pde -> eIn "operation" $ do
pde' <- case pde of
Yes de | optres -> liftM yes $ comp de
_ -> return pde
return $ ResOper pty pde'
_ -> return info
where
comp = if optres then computeConcrete gr else computeConcreteRec gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
optim = maybe "all" id $ getOptVal oopts useOptimizer
optres = case optim of
"noexpand" -> False
_ -> True
evalCncInfo ::
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
evalCncInfo opts gr cnc abs (c,info) = do
seq (prtIf (oElem beVerbose opts) c) $ return ()
errIn ("optimizing" +++ prt c) $ case info of
CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of
(Yes typ, Yes de) ->
liftM yes $ pEval ([(varStr, typeStr)], typ) de
(Yes typ, Nope) ->
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
(May b, Nope) ->
return $ May b
_ -> return pde -- indirection
ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
return (c, CncCat ptyp pde' ppr')
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
pde' <- case pde of
Yes de | notNewEval -> do
liftM yes $ pEval ty de
_ -> return pde
ppr' <- liftM yes $ evalPrintname gr c ppr pde'
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
_ -> return (c,info)
where
pEval = partEval opts gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
notNewEval = not (oElem oEval opts)
-- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
let vars = map fst context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm3 <- if globalTable
then etaExpand subst trm1 >>= outCase subst
else etaExpand subst trm1
return $ mkAbs vars trm3
where
globalTable = oElem showAll opts --- i -all
comp g t = {- refreshTerm t >>= -} computeTerm gr g t
etaExpand su t = do
t' <- comp su t
case t' of
R _ | rightType t' -> comp su t' --- return t' wo noexpand...
_ -> recordExpand val t' >>= comp su
-- don't eta expand records of right length (correct by type checking)
rightType t = case (t,val) of
(R rs, RecType ts) -> length rs == length ts
_ -> False
outCase subst t = do
pts <- getParams context
let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
if null args
then return t
else do
let argtyp = RecType $ tuple2recordType ptyps
let pvars = map (Vr . zIdent . prt) args -- gets eliminated
patt <- term2patt $ R $ tuple2record $ pvars
let t' = replace (zip args pvars) t
t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
return $ S t1 $ R $ tuple2record args
--- notice: this assumes that all lin types follow the "old JFP style"
getParams = liftM concat . mapM getParam
getParam (argv,RecType rs) = return
[(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)]
---getParam (_,ty) | ty==typeStr = return [] --- in lindef
getParam (av,ty) =
Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av)
--- all lin types are rec types
replace :: [(Term,Term)] -> Term -> Term
replace reps trm = case trm of
-- this is the important case
P _ _ -> maybe trm id $ lookup trm reps
_ -> composSafeOp (replace reps) trm
occur t trm = case trm of
-- this is the important case
P _ _ -> t == trm
S x y -> occur t y || occur t x
App f x -> occur t x || occur t f
Abs _ f -> occur t f
R rs -> any (occur t) (map (snd . snd) rs)
T _ cs -> any (occur t) (map snd cs)
C x y -> occur t x || occur t y
Glue x y -> occur t x || occur t y
ExtR x y -> occur t x || occur t y
FV ts -> any (occur t) ts
V _ ts -> any (occur t) ts
Let (_,(_,x)) y -> occur t x || occur t y
_ -> False
-- here we must be careful not to reduce
-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ;
recordExpand :: Type -> Term -> Err Term
recordExpand typ trm = case unComputed typ of
RecType tys -> case trm of
FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
_ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
_ -> return trm
-- | auxiliaries for compiling the resource
mkLinDefault :: SourceGrammar -> Type -> Err Term
mkLinDefault gr typ = do
case unComputed typ of
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
_ -> prtBad "linearization type must be a record type, not" typ
where
mkDefField typ = case unComputed typ of
Table p t -> do
t' <- mkDefField t
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort "Str" -> return $ Vr varStr
QC q p -> lookupFirstTag gr q p
RecType r -> do
let (ls,ts) = unzip r
ts' <- mapM mkDefField ts
return $ R $ [assign l t | (l,t) <- zip ls ts']
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> prtBad "linearization type field cannot be" typ
-- | Form the printname: if given, compute. If not, use the computed
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
--- We cannot use linearization at this stage, since we do not know the
--- defaults we would need for question marks - and we're not yet in canon.
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
evalPrintname gr c ppr lin =
case ppr of
Yes pr -> comp pr
_ -> case lin of
Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
_ -> return $ K $ prt c ----
where
comp = computeConcrete gr
oneBranch t = case t of
Abs _ b -> oneBranch b
R (r:_) -> oneBranch $ snd $ snd r
T _ (c:_) -> oneBranch $ snd c
V _ (c:_) -> oneBranch c
FV (t:_) -> oneBranch t
C x y -> C (oneBranch x) (oneBranch y)
S x _ -> oneBranch x
P x _ -> oneBranch x
Alts (d,_) -> oneBranch d
_ -> t
--- very unclean cleaner
clean s = case s of
'+':'+':' ':cs -> clean cs
'"':cs -> clean cs
c:cs -> c: clean cs
_ -> s

77
src-3.0/GF/Compile/PGrammar.hs
View File

@@ -1,77 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/25 10:27:12 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.PGrammar (pTerm, pTrm, pTrms,
pMeta, pzIdent,
string2ident
) where
---import LexGF
import GF.Source.ParGF
import GF.Source.SourceToGrammar (transExp)
import GF.Grammar.Grammar
import GF.Infra.Ident
import qualified GF.Canon.AbsGFC as A
import qualified GF.Canon.GFC as G
import GF.Compile.GetGrammar
import GF.Grammar.Macros
import GF.Grammar.MMacros
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
pTerm :: String -> Err Term
pTerm s = do
e <- pExp $ myLexer (BS.pack s)
transExp e
pTrm :: String -> Term
pTrm = errVal (vr (zIdent "x")) . pTerm ---
pTrms :: String -> [Term]
pTrms = map pTrm . sep [] where
sep t cs = case cs of
',' : cs2 -> reverse t : sep [] cs2
c : cs2 -> sep (c:t) cs2
_ -> [reverse t]
pTrm' :: String -> [Term]
pTrm' = err (const []) singleton . pTerm
pMeta :: String -> Integer
pMeta _ = 0 ---
pzIdent :: String -> Ident
pzIdent = zIdent
{-
string2formsAndTerm :: String -> ([Term],Term)
string2formsAndTerm s = case s of
'[':_:_ -> case span (/=']') s of
(x,_:y) -> (pTrms (tail x), pTrm y)
_ -> ([],pTrm s)
_ -> ([], pTrm s)
-}
string2ident :: String -> Err Ident
string2ident s = return $ string2var s
{-
-- reads the Haskell datatype
readGrammar :: String -> Err GrammarST
readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> return x
[] -> Bad "no parse of Grammar"
_ -> Bad "ambiguous parse of Grammar"
-}

84
src-3.0/GF/Compile/PrOld.hs
View File

@@ -1,84 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PrOld
-- Maintainer : GF
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- a hack to print gf2 into gf1 readable files
-- Works only for canonical grammars, printed into GFC. Otherwise we would have
-- problems with qualified names.
-- --- printnames are not preserved, nor are lindefs
-----------------------------------------------------------------------------
module GF.Compile.PrOld (printGrammarOld, stripTerm) where
import GF.Grammar.PrGrammar
import GF.Canon.CanonToGrammar
import qualified GF.Canon.GFC as GFC
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Macros
import GF.Infra.Modules
import qualified GF.Source.PrintGF as P
import GF.Source.GrammarToSource
import Data.List
import GF.Data.Operations
import GF.Infra.UseIO
printGrammarOld :: GFC.CanonGrammar -> String
printGrammarOld gr = err id id $ do
as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m]
cs0 <- mapM canon2sourceModule
[im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m]
as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0
cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0
return $ unlines $ map prj $ srt as1 ++ srt cs1
where
js (ModMod m) = jments m
srt = sortBy (\ (i,_) (j,_) -> compare i j)
prj ii = P.printTree $ trAnyDef ii
stripInfo :: (Ident,Info) -> [(Ident,Info)]
stripInfo (c,i) = case i of
AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
ResParam (Yes (ps,m)) -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing))
CncCat (Yes ty) _ _ -> rc $
CncCat (Yes (stripTerm ty)) nope nope
CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope
_ -> []
where
rc j = [(c,j)]
stripContext co = [(x, stripTerm t) | (x,t) <- co]
stripTerm :: Term -> Term
stripTerm t = case t of
Q _ c -> Vr c
QC _ c -> Vr c
T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where
ti' = case ti of
TTyped ty -> TTyped $ stripTerm ty
TComp ty -> TComp $ stripTerm ty
TWild ty -> TWild $ stripTerm ty
_ -> ti
---- R [] -> EInt 8 --- GF 1.2 parser doesn't accept empty records
---- RecType [] -> Cn (zIdent "Int") ---
_ -> composSafeOp stripTerm t
stripPattern p = case p of
PC c [] -> PV c
PP _ c [] -> PV c
PC c ps -> PC c (map stripPattern ps)
PP _ c ps -> PC c (map stripPattern ps)
PR lps -> PR [(l, stripPattern p) | (l,p) <- lps]
PT t p -> PT (stripTerm t) (stripPattern p)
_ -> p

568
src-3.0/GF/Compile/ShellState.hs
View File

@@ -1,568 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : ShellState
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:41 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.53 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.ShellState where
import GF.Data.Operations
import GF.Canon.GFC
import GF.Canon.AbsGFC
import GF.GFCC.CId
--import GF.GFCC.DataGFCC(mkGFCC)
import GF.GFCC.Macros (lookFCFG)
import GF.Canon.CanonToGFCC
import GF.Grammar.Macros
import GF.Grammar.MMacros
import GF.Canon.Look
import GF.Canon.Subexpressions
import GF.Grammar.LookAbs
import GF.Compile.ModDeps
import GF.Compile.Evaluate
import qualified GF.Infra.Modules as M
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.PrGrammar as P
import GF.CF.CF
import GF.CF.CFIdent
import GF.CF.CanonToCF
import GF.UseGrammar.Morphology
import GF.Probabilistic.Probabilistic
import GF.Compile.NoParse
import GF.Infra.Option
import GF.Infra.Ident
import GF.Infra.UseIO (justModuleName)
import GF.System.Arch (ModTime)
import qualified Transfer.InterpreterAPI as T
import GF.Formalism.FCFG
import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE
import qualified GF.Conversion.GFC as Cnv
import qualified GF.Conversion.SimpleToFCFG as FCnv
import qualified GF.Parsing.GFC as Prs
import Control.Monad (mplus)
import Data.List (nub,nubBy)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
-- | multilingual state with grammars and options
data ShellState = ShSt {
abstract :: Maybe Ident , -- ^ pointer to actual abstract, if not empty st
concrete :: Maybe Ident , -- ^ pointer to primary concrete
concretes :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active
canModules :: CanonGrammar , -- ^ compiled abstracts and concretes
srcModules :: G.SourceGrammar , -- ^ saved resource modules
cfs :: [(Ident,CF)] , -- ^ context-free grammars (small, no parameters, very over-generating)
abstracts :: [(Ident,[Ident])], -- ^ abstracts and their associated concretes
mcfgs :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3)
fcfgs :: [(Ident, FGrammar)], -- ^ FCFG, optimized MCFG by Krasimir Angelov
cfgs :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg
-- (large, with parameters, no-so overgenerating)
pInfos :: [(Ident, Prs.PInfo)], -- ^ parsing information (compiled mcfg&cfg grammars)
morphos :: [(Ident,Morpho)], -- ^ morphologies
treebanks :: [(Ident,Treebank)], -- ^ treebanks
probss :: [(Ident,Probs)], -- ^ probability distributions
gloptions :: Options, -- ^ global options
readFiles :: [(String,(FilePath,ModTime))],-- ^ files read
absCats :: [(G.Cat,(G.Context,
[(G.Fun,G.Type)],
[((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts,
-- functions to them,
-- functions on them)
statistics :: [Statistics], -- ^ statistics on grammars
transfers :: [(Ident,T.Env)], -- ^ transfer modules
evalEnv :: EEnv -- ^ evaluation environment
}
type Treebank = Map.Map String [String] -- string, trees
actualConcretes :: ShellState -> [((Ident,Ident),Bool)]
actualConcretes sh = nub [((c,c),b) |
Just a <- [abstract sh],
((c,_),_) <- concretes sh, ----concretesOfAbstract sh a,
let b = True -----
]
concretesOfAbstract :: ShellState -> Ident -> [Ident]
concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs]
data Statistics =
StDepTypes Bool -- ^ whether there are dependent types
| StBoundVars [G.Cat] -- ^ which categories have bound variables
--- -- etc
deriving (Eq,Ord)
emptyShellState :: ShellState
emptyShellState = ShSt {
abstract = Nothing,
concrete = Nothing,
concretes = [],
canModules = M.emptyMGrammar,
srcModules = M.emptyMGrammar,
cfs = [],
abstracts = [],
mcfgs = [],
fcfgs = [],
cfgs = [],
pInfos = [],
morphos = [],
treebanks = [],
probss = [],
gloptions = noOptions,
readFiles = [],
absCats = [],
statistics = [],
transfers = [],
evalEnv = emptyEEnv
}
optInitShellState :: Options -> ShellState
optInitShellState os = addGlobalOptions os emptyShellState
type Language = Ident
language :: String -> Language
language = identC
prLanguage :: Language -> String
prLanguage = prIdent
-- | grammar for one language in a state, comprising its abs and cnc
data StateGrammar = StGr {
absId :: Ident,
cncId :: Ident,
grammar :: CanonGrammar,
cf :: CF,
mcfg :: Cnv.MGrammar,
fcfg :: FGrammar,
cfg :: Cnv.CGrammar,
pInfo :: Prs.PInfo,
morpho :: Morpho,
probs :: Probs,
loptions :: Options
}
emptyStateGrammar :: StateGrammar
emptyStateGrammar = StGr {
absId = identC "#EMPTY", ---
cncId = identC "#EMPTY", ---
grammar = M.emptyMGrammar,
cf = emptyCF,
mcfg = [],
fcfg = ([], Map.empty),
cfg = [],
pInfo = Prs.buildPInfo [] ([], Map.empty) [],
morpho = emptyMorpho,
probs = emptyProbs,
loptions = noOptions
}
-- analysing shell grammar into parts
stateGrammarST :: StateGrammar -> CanonGrammar
stateCF :: StateGrammar -> CF
stateMCFG :: StateGrammar -> Cnv.MGrammar
stateFCFG :: StateGrammar -> FGrammar
stateCFG :: StateGrammar -> Cnv.CGrammar
statePInfo :: StateGrammar -> Prs.PInfo
stateMorpho :: StateGrammar -> Morpho
stateProbs :: StateGrammar -> Probs
stateOptions :: StateGrammar -> Options
stateGrammarWords :: StateGrammar -> [String]
stateGrammarLang :: StateGrammar -> (CanonGrammar, Ident)
stateGrammarST = grammar
stateCF = cf
stateMCFG = mcfg
stateFCFG = fcfg
stateCFG = cfg
statePInfo = pInfo
stateMorpho = morpho
stateProbs = probs
stateOptions = loptions
stateGrammarWords = allMorphoWords . stateMorpho
stateGrammarLang st = (grammar st, cncId st)
---- this should be computed at compile time and stored
stateHasHOAS :: StateGrammar -> Bool
stateHasHOAS = hasHOAS . stateGrammarST
cncModuleIdST :: StateGrammar -> CanonGrammar
cncModuleIdST = stateGrammarST
-- | form a shell state from a canonical grammar
grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState
grammar2shellState opts (gr,sgr) =
updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe?
-- | update a shell state from a canonical grammar
updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState ->
((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) ->
Err ShellState
updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let cgr0 = M.updateMGrammar (canModules sh) gr
-- a0 = abstract of old state
-- a1 = abstract of compiled grammar
let a0 = abstract sh
a1 <- return $ case mcnc of
Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc
_ -> M.greatestAbstract cgr0
-- abstr0 = a1 if it exists
let (abstr0,isNew) = case (a0,a1) of
(Just a, Just b) | a /= b -> (a1, True)
(Nothing, Just _) -> (a1, True)
_ -> (a0, False)
let concrs0 = maybe [] (M.allConcretes cgr0) abstr0
let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $
maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh
let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0)
purge = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo)))
let cgr = M.MGrammar $ purge $ M.modules cgr0
let oldConcrs = map (snd . fst) (concretes sh)
newConcrs = maybe [] (M.allConcretes gr) abstr0
toRetain (c,v) = notElem c newConcrs
let complete m = case M.lookupModule gr m of
Ok mo -> not $ isIncompleteCanon (m,mo)
_ -> False
let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs
concr0 = ifNull Nothing (return . head) concrs
notInrts f = notElem f $ map fst rts
subcgr = unSubelimCanon cgr
cf's0 <- if (not (oElem (iOpt "docf") opts) && -- cf only built with -docf
(oElem noCF opts || not (hasHOAS cgr))) -- or HOAS, if not -nocf
then return $ map snd $ cfs sh
else mapM (canon2cf opts ign subcgr) newConcrs
let cf's = zip newConcrs cf's0 ++ filter toRetain (cfs sh)
let morphs = [(c,mkMorpho subcgr c) | c <- newConcrs] ++ filter toRetain (morphos sh)
let probss = [] -----
let fromGFC = snd . snd . Cnv.convertGFC opts
(mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs
gfcc = canon2gfcc opts cgr ---- UTF8
fcfgs = [(c,g) | c@(IC cn) <- concrs, Just g <- [lookFCFG gfcc (CId cn)]]
pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs
let funs = funRulesOf cgr
let cats = allCatsOf cgr
let csi = [(c,(co,
[(fun,typ) | (fun,typ) <- funs, compatType tc typ],
funsOnTypeFs compatType funs tc))
| (c,co) <- cats, let tc = cat2val co c]
let deps = True ---- not $ null $ allDepCats cgr
let binds = [] ---- allCatsWithBind cgr
let src = M.updateMGrammar (srcModules sh) sgr
return $ ShSt {
abstract = abstr0,
concrete = concr0,
concretes = zip (zip concrs concrs) (repeat True),
canModules = cgr,
srcModules = src,
cfs = cf's,
abstracts = maybe [] (\a -> [(a,concrs)]) abstr0,
mcfgs = zip concrs mcfgs,
fcfgs = fcfgs,
cfgs = zip concrs cfgs,
pInfos = zip concrs pInfos,
morphos = morphs,
treebanks = treebanks sh,
probss = zip concrs probss,
gloptions = gloptions sh, --- opts, -- this would be command-line options
readFiles = [ft | ft@(f,(_,_)) <- readFiles sh, notInrts f] ++ rts,
absCats = csi,
statistics = [StDepTypes deps,StBoundVars binds],
transfers = transfers sh,
evalEnv = eenv
}
prShellStateInfo :: ShellState -> String
prShellStateInfo sh = unlines [
"main abstract : " +++ abstractName sh,
"main concrete : " +++ maybe "(none)" P.prt (concrete sh),
"actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)),
"all abstracts : " +++ unwords (map (P.prt . fst) (abstracts sh)),
"all concretes : " +++ unwords (map (P.prt . fst . fst) (concretes sh)),
"canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))),
"source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))),
"global options : " +++ prOpts (gloptions sh),
"transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh)),
"treebanks : " +++ unwords (map (P.prt . fst) (treebanks sh))
]
abstractName :: ShellState -> String
abstractName sh = maybe "(none)" P.prt (abstract sh)
-- | throw away those abstracts that are not needed --- could be more aggressive
filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar
filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
ms = M.modules cgr
needed (i,_) = elem i needs
needs = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts]
dep i a = elem i (ext mse a)
mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]]
ext es a = case lookup a es of
Just e -> a : concatMap (ext es) e ---- FIX multiple exts
_ -> []
purgeShellState :: ShellState -> ShellState
purgeShellState sh = ShSt {
abstract = abstr,
concrete = concrete sh,
concretes = concrs,
canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh,
srcModules = M.emptyMGrammar,
cfs = cfs sh,
abstracts = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr,
mcfgs = mcfgs sh,
fcfgs = fcfgs sh,
cfgs = cfgs sh,
pInfos = pInfos sh,
morphos = morphos sh,
treebanks = treebanks sh,
probss = probss sh,
gloptions = gloptions sh,
readFiles = [],
absCats = absCats sh,
statistics = statistics sh,
transfers = transfers sh,
evalEnv = emptyEEnv
}
where
abstr = abstract sh
concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed]
isSingle = length (abstracts sh) == 1
needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh)
complete = not . isIncompleteCanon
changeMain :: Maybe Ident -> ShellState -> Err ShellState
changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) =
return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee)
changeMain
(Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) =
case lookup c (M.modules ms) of
Just _ -> do
a <- M.abstractOfConcrete ms c
let cas = M.allConcretes ms a
let cs' = [((c,c),True) | c <- cas]
return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs
pinfos mos tbs pbs os rs acs s trs ee)
_ -> P.prtBad "The state has no concrete syntax named" c
-- | form just one state grammar, if unique, from a canonical grammar
grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar
grammar2stateGrammar opts gr = do
st <- grammar2shellState opts (gr,M.emptyMGrammar)
concr <- maybeErr "no concrete syntax" $ concrete st
return $ stateGrammarOfLang st concr
resourceOfShellState :: ShellState -> Maybe Ident
resourceOfShellState = M.greatestResource . srcModules
qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
qualifTop gr (_,c) = (absId gr,c)
stateGrammarOfLang :: ShellState -> Language -> StateGrammar
stateGrammarOfLang = stateGrammarOfLangOpt True
stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar
stateGrammarOfLangOpt purg st0 l = StGr {
absId = err (const (identC "Abs")) id $ M.abstractOfConcrete allCan l, ---
cncId = l,
grammar = allCan,
cf = maybe emptyCF id (lookup l (cfs st)),
mcfg = maybe [] id $ lookup l $ mcfgs st,
fcfg = maybe ([],Map.empty) id $ lookup l $ fcfgs st,
cfg = maybe [] id $ lookup l $ cfgs st,
pInfo = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st,
morpho = maybe emptyMorpho id (lookup l (morphos st)),
probs = maybe emptyProbs id (lookup l (probss st)),
loptions = errVal noOptions $ lookupOptionsCan allCan
}
where
st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0
allCan = canModules st
grammarOfLang :: ShellState -> Language -> CanonGrammar
cfOfLang :: ShellState -> Language -> CF
morphoOfLang :: ShellState -> Language -> Morpho
probsOfLang :: ShellState -> Language -> Probs
optionsOfLang :: ShellState -> Language -> Options
grammarOfLang st = stateGrammarST . stateGrammarOfLang st
cfOfLang st = stateCF . stateGrammarOfLang st
morphoOfLang st = stateMorpho . stateGrammarOfLang st
probsOfLang st = stateProbs . stateGrammarOfLang st
optionsOfLang st = stateOptions . stateGrammarOfLang st
removeLang :: Language -> ShellState -> ShellState
removeLang lang st = purgeShellState $ st{concretes = concs1} where
concs1 = filter ((/=lang) . snd . fst) $ concretes st
-- | the last introduced grammar, stored in options, is the default for operations
firstStateGrammar :: ShellState -> StateGrammar
firstStateGrammar st = errVal (stateAbstractGrammar st) $ do
concr <- maybeErr "no concrete syntax" $ concrete st
return $ stateGrammarOfLang st concr
mkStateGrammar :: ShellState -> Language -> StateGrammar
mkStateGrammar = stateGrammarOfLang
stateAbstractGrammar :: ShellState -> StateGrammar
stateAbstractGrammar st = StGr {
absId = maybe (identC "Abs") id (abstract st), ---
cncId = identC "#Cnc", ---
grammar = canModules st, ---- only abstarct ones
cf = emptyCF,
mcfg = [],
fcfg = ([],Map.empty),
cfg = [],
pInfo = Prs.buildPInfo [] ([],Map.empty) [],
morpho = emptyMorpho,
probs = emptyProbs,
loptions = gloptions st ----
}
-- analysing shell state into parts
globalOptions :: ShellState -> Options
allLanguages :: ShellState -> [Language]
allTransfers :: ShellState -> [Ident]
allCategories :: ShellState -> [G.Cat]
allStateGrammars :: ShellState -> [StateGrammar]
allStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
allGrammarFileNames :: ShellState -> [String]
allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
allActiveGrammars :: ShellState -> [StateGrammar]
globalOptions = gloptions
--allLanguages = map (fst . fst) . concretes
allLanguages = map (snd . fst) . actualConcretes
allTransfers = map fst . transfers
allCategories = map fst . allCatsOf . canModules
allStateGrammars = map snd . allStateGrammarsWithNames
allStateGrammarsWithNames st =
[(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st]
allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st]
allActiveStateGrammarsWithNames st =
[(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual
allActiveGrammars = map snd . allActiveStateGrammarsWithNames
pathOfModule :: ShellState -> Ident -> FilePath
pathOfModule sh m = maybe "module not found" fst $ lookup (P.prt m) $ readFiles sh
-- command-line option -lang=foo overrides the actual grammar in state
grammarOfOptState :: Options -> ShellState -> StateGrammar
grammarOfOptState opts st =
maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $
getOptVal opts useLanguage
languageOfOptState :: Options -> ShellState -> Maybe Language
languageOfOptState opts st =
maybe (concrete st) (return . language) $ getOptVal opts useLanguage
-- | command-line option -cat=foo overrides the possible start cat of a grammar
firstCatOpts :: Options -> StateGrammar -> CFCat
firstCatOpts opts sgr =
maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $
getOptVal opts firstCat
-- | the first cat for random generation
firstAbsCat :: Options -> StateGrammar -> G.QIdent
firstAbsCat opts = cfCat2Cat . firstCatOpts opts
-- | Gets the start category for the grammar from the options.
-- If the startcat is not set in the options, we look
-- for a flag in the grammar. If there is no flag in the
-- grammar, S is returned.
startCatStateOpts :: Options -> StateGrammar -> CFCat
startCatStateOpts opts sgr =
string2CFCat a (fromMaybe "S" (optsStartCat `mplus` grStartCat))
where optsStartCat = getOptVal opts gStartCat
grStartCat = getOptVal (stateOptions sgr) gStartCat
a = P.prt (absId sgr)
-- | a grammar can have start category as option startcat=foo ; default is S
stateFirstCat :: StateGrammar -> CFCat
stateFirstCat = startCatStateOpts noOptions
stateIsWord :: StateGrammar -> String -> Bool
stateIsWord sg = isKnownWord (stateMorpho sg)
addProbs :: (Ident,Probs) -> ShellState -> Err ShellState
addProbs ip@(lang,probs) sh = do
let gr = grammarOfLang sh lang
probs' <- checkGrammarProbs gr probs
let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh)
return $ sh{probss = pbs'}
addTransfer :: (Ident,T.Env) -> ShellState -> ShellState
addTransfer it@(i,_) sh =
sh {transfers = it : filter ((/= i) . fst) (transfers sh)}
addTreebanks :: [(Ident,Treebank)] -> ShellState -> ShellState
addTreebanks its sh = sh {treebanks = its ++ treebanks sh}
findTreebank :: ShellState -> Ident -> Err Treebank
findTreebank sh i = maybeErr "no treebank found" $ lookup i $ treebanks sh
-- modify state
type ShellStateOper = ShellState -> ShellState
type ShellStateOperErr = ShellState -> Err ShellState
reinitShellState :: ShellStateOper
reinitShellState = const emptyShellState
languageOn, languageOff :: Language -> ShellStateOper
languageOn = languageOnOff True
languageOff = languageOnOff False
languageOnOff :: Bool -> Language -> ShellStateOper
--- __________ this is OBSOLETE
languageOnOff b lang sh = sh {concretes = cs'} where
cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh]
changeOptions :: (Options -> Options) -> ShellStateOper
--- __________ this is OBSOLETE
changeOptions f sh = sh {gloptions = f (gloptions sh)}
addGlobalOptions :: Options -> ShellStateOper
addGlobalOptions = changeOptions . addOptions
removeGlobalOptions :: Options -> ShellStateOper
removeGlobalOptions = changeOptions . removeOptions

108
src-3.0/GF/Compile/Wordlist.hs
View File

@@ -1,108 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Wordlist
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date:
-- > CVS $Author:
-- > CVS $Revision:
--
-- Compile a gfwl file (multilingual word list) to an abstract + concretes
-----------------------------------------------------------------------------
module GF.Compile.Wordlist (mkWordlist) where
import GF.Data.Operations
import GF.Infra.UseIO
import Data.List
import Data.Char
import System.FilePath
-- read File.gfwl, write File.gf (abstract) and a set of concretes
-- return the names of the concretes
mkWordlist :: FilePath -> IO [FilePath]
mkWordlist file = do
s <- readFileIf file
let abs = dropExtension file
let (cnchs,wlist) = pWordlist abs $ filter notComment $ lines s
let (gr,grs) = mkGrammars abs cnchs wlist
let cncfs = [cnc ++ ".gf" | (cnc,_) <- cnchs]
mapM_ (uncurry writeFile) $ (abs ++ ".gf",gr) : zip cncfs grs
putStrLn $ "wrote " ++ unwords ((abs ++ ".gf") : cncfs)
return cncfs
{-
-- syntax of files, e.g.
# Svenska - Franska - Finska -- names of concretes
berg - montagne - vuori -- word entry
-- this creates:
cat S ;
fun berg_S : S ;
lin berg_S = {s = ["berg"]} ;
lin berg_S = {s = ["montagne"]} ;
lin berg_S = {s = ["vuori"]} ;
-- support for different categories to be elaborated. The syntax it
Verb . klättra - grimper / escalader - kiivetä / kiipeillä
-- notice that a word can have several alternative (separator /)
-- and that an alternative can consist of several words
-}
type CncHeader = (String,String) -- module name, module header
type Wordlist = [(String, [[String]])] -- cat, variants for each cnc
pWordlist :: String -> [String] -> ([CncHeader],Wordlist)
pWordlist abs ls = (headers,rules) where
(hs,rs) = span ((=="#") . take 1) ls
headers = map mkHeader $ chunks "-" $ filter (/="#") $ words $ concat hs
rules = map (mkRule . words) rs
mkHeader ws = case ws of
w:ws2 -> (w, unwords ("concrete":w:"of":abs:"=":ws2))
mkRule ws = case ws of
cat:".":vs -> (cat, mkWords vs)
_ -> ("S", mkWords ws)
mkWords = map (map unwords . chunks "/") . chunks "-"
mkGrammars :: String -> [CncHeader] -> Wordlist -> (String,[String])
mkGrammars ab hs wl = (abs,cncs) where
abs = unlines $ map unwords $
["abstract",ab,"=","{"]:
cats ++
funs ++
[["}"]]
cncs = [unlines $ (h ++ " {") : map lin rs ++ ["}"] | ((_,h),rs) <- zip hs rss]
cats = [["cat",c,";"] | c <- nub $ map fst wl]
funs = [["fun", f , ":", c,";"] | (f,c,_) <- wlf]
wlf = [(ident f c, c, ws) | (c,ws@(f:_)) <- wl]
rss = [[(f, wss !! i) | (f,_,wss) <- wlf] | i <- [0..length hs - 1]]
lin (f,ss) = unwords ["lin", f, "=", "{s", "=", val ss, "}", ";"]
val ss = case ss of
[w] -> quote w
_ -> "variants {" ++ unwords (intersperse ";" (map quote ss)) ++ "}"
quote w = "[" ++ prQuotedString w ++ "]"
ident f c = concat $ intersperse "_" $ words (head f) ++ [c]
notComment s = not (all isSpace s) && take 2 s /= "--"

157
src-3.0/GF/Conversion/GFC.hs
View File

@@ -1,157 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/01 09:53:18 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.14 $
--
-- All conversions from GFC
-----------------------------------------------------------------------------
module GF.Conversion.GFC
(module GF.Conversion.GFC,
SGrammar, EGrammar, MGrammar, CGrammar) where
import GF.Infra.Option
import GF.Canon.GFC (CanonGrammar)
import GF.Infra.Ident (Ident, identC)
import qualified GF.Infra.Modules as M
import GF.Formalism.GCFG (Rule(..), Abstract(..))
import GF.Formalism.SimpleGFC (decl2cat)
import GF.Formalism.CFG (CFRule(..))
import GF.Formalism.Utilities (symbol, name2fun)
import GF.Conversion.Types
import qualified GF.Conversion.GFCtoSimple as G2S
import qualified GF.Conversion.SimpleToFinite as S2Fin
import qualified GF.Conversion.RemoveSingletons as RemSing
import qualified GF.Conversion.RemoveErasing as RemEra
import qualified GF.Conversion.RemoveEpsilon as RemEps
import qualified GF.Conversion.SimpleToMCFG as S2M
import qualified GF.Conversion.MCFGtoCFG as M2C
import GF.Infra.Print
import GF.System.Tracing
----------------------------------------------------------------------
-- * GFC -> MCFG & CFG, using options to decide which conversion is used
convertGFC :: Options -> (CanonGrammar, Ident)
-> (SGrammar, (EGrammar, (MGrammar, CGrammar)))
convertGFC opts = \g -> let s = g2s g
e = s2e s
m = e2m e
in trace2 "Options" (show opts) (s, (e, (m, e2c e)))
where e2c = M2C.convertGrammar
e2m = case getOptVal opts firstCat of
Just cat -> flip erasing [identC cat]
Nothing -> flip erasing []
s2e = case getOptVal opts gfcConversion of
Just "strict" -> strict
Just "finite-strict" -> strict
Just "epsilon" -> epsilon . nondet
_ -> nondet
g2s = case getOptVal opts gfcConversion of
Just "finite" -> finite . simple
Just "finite2" -> finite . finite . simple
Just "finite3" -> finite . finite . finite . simple
Just "singletons" -> single . simple
Just "finite-singletons" -> single . finite . simple
Just "finite-strict" -> finite . simple
_ -> simple
simple = G2S.convertGrammar
strict = S2M.convertGrammarStrict
nondet = S2M.convertGrammarNondet
epsilon = RemEps.convertGrammar
finite = S2Fin.convertGrammar
single = RemSing.convertGrammar
erasing = RemEra.convertGrammar
gfc2simple :: Options -> (CanonGrammar, Ident) -> SGrammar
gfc2simple opts = fst . convertGFC opts
gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar
gfc2mcfg opts g = mcfg
where
(mcfg, _) = snd (snd (convertGFC opts g))
gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar
gfc2cfg opts g = cfg
where
(_, cfg) = snd (snd (convertGFC opts g))
----------------------------------------------------------------------
-- * single step conversions
{-
gfc2simple :: (CanonGrammar, Ident) -> SGrammar
gfc2simple = G2S.convertGrammar
simple2finite :: SGrammar -> SGrammar
simple2finite = S2Fin.convertGrammar
removeSingletons :: SGrammar -> SGrammar
removeSingletons = RemSing.convertGrammar
simple2mcfg_nondet :: SGrammar -> EGrammar
simple2mcfg_nondet =
simple2mcfg_strict :: SGrammar -> EGrammar
simple2mcfg_strict = S2M.convertGrammarStrict
mcfg2cfg :: EGrammar -> CGrammar
mcfg2cfg = M2C.convertGrammar
removeErasing :: EGrammar -> [SCat] -> MGrammar
removeErasing = RemEra.convertGrammar
removeEpsilon :: EGrammar -> EGrammar
removeEpsilon = RemEps.convertGrammar
-}
----------------------------------------------------------------------
-- * converting to some obscure formats
gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun]
gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) |
Rule (Abs decl decls name) _ <- G2S.convertGrammar gr ]
abstract2skvatt :: [Abstract SCat Fun] -> String
abstract2skvatt gr = skvatt_hdr ++ concatMap abs2pl gr
where abs2pl (Abs cat [] fun) = prtQuoted cat ++ " ---> " ++
"\"" ++ prt fun ++ "\".\n"
abs2pl (Abs cat cats fun) =
prtQuoted cat ++ " ---> " ++
"\"(" ++ prt fun ++ "\"" ++
prtBefore ", \" \", " (map prtQuoted cats) ++ ", \")\".\n"
cfg2skvatt :: CGrammar -> String
cfg2skvatt gr = skvatt_hdr ++ concatMap cfg2pl gr
where cfg2pl (CFRule cat syms _name) =
prtQuoted cat ++ " ---> " ++
if null syms then "\"\".\n" else
prtSep ", " (map (symbol prtQuoted prTok) syms) ++ ".\n"
prTok tok = "\"" ++ tok ++ " \""
skvatt_hdr = ":- use_module(library(skvatt)).\n" ++
":- use_module(library(utils), [repeat/1]).\n" ++
"corpus(File, StartCat, Depth, Size) :- \n" ++
" set_flag(gendepth, Depth),\n" ++
" tell(File), repeat(Size),\n" ++
" generate_words(StartCat, String), format('~s~n~n', [String]),\n" ++
" write(user_error, '.'),\n" ++
" fail ; told.\n\n"
prtQuoted :: Print a => a -> String
prtQuoted a = "'" ++ prt a ++ "'"

175
src-3.0/GF/Conversion/GFCtoSimple.hs
View File

@@ -1,175 +0,0 @@
---------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/07 11:24:51 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.15 $
--
-- Converting GFC to SimpleGFC
--
-- the conversion might fail if the GFC grammar has dependent or higher-order types,
-- or if the grammar contains bound pattern variables
-- (use -optimize=values/share/none when importing)
--
-- TODO: lift all functions to the 'Err' monad
-----------------------------------------------------------------------------
module GF.Conversion.GFCtoSimple
(convertGrammar) where
import qualified GF.Canon.AbsGFC as A
import qualified GF.Infra.Ident as I
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Formalism.Utilities
import GF.Conversion.Types
import GF.UseGrammar.Linear (expandLinTables)
import GF.Canon.GFC (CanonGrammar)
import GF.Canon.MkGFC (grammar2canon)
import GF.Canon.Subexpressions (unSubelimCanon)
import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat)
import qualified GF.Canon.CMacros as CMacros (defLinType)
import GF.Data.Operations (err, errVal)
--import qualified Modules as M
import GF.System.Tracing
import GF.Infra.Print
----------------------------------------------------------------------
type Env = (CanonGrammar, I.Ident)
convertGrammar :: Env -> SGrammar
convertGrammar (g,i) = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $
tracePrt "GFCtoSimple - simpleGFC rules" (prt . length) $
[ convertAbsFun gram fun typing |
A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
A.AbsDFun fun typing _ <- defs ]
where A.Gr modules = grammar2canon (fst gram)
gram = (unSubelimCanon g,i)
convertAbsFun :: Env -> I.Ident -> A.Exp -> SRule
convertAbsFun gram fun typing = -- trace2 "GFCtoSimple - converting function" (prt fun) $
Rule abs cnc
where abs = convertAbstract [] fun typing
cnc = convertConcrete gram abs
----------------------------------------------------------------------
-- abstract definitions
convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name
convertAbstract env fun (A.EProd x a b)
= convertAbstract (convertAbsType x' [] a : env) fun b
where x' = if x==I.identC "h_" then anyVar else x
convertAbstract env fun a
= Abs (convertAbsType anyVar [] a) (reverse env) name
where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ]
convertAbsType :: Var -> [FOType SCat] -> A.Exp -> SDecl
convertAbsType x args (A.EProd _ a b) = convertAbsType x (convertType [] a : args) b
convertAbsType x args a = Decl x (reverse args ::--> convertType [] a)
convertType :: [TTerm] -> A.Exp -> FOType SCat
convertType args (A.EApp a b) = convertType (convertExp [] b : args) a
convertType args (A.EAtom at) = convertCat at ::@ reverse args
convertType args (A.EProd _ _ b) = convertType args b ---- AR 7/10 workaround
convertType args exp = error $ "GFCtoSimple.convertType: " ++ prt exp
{- Exp from GF/Canon/GFC.cf:
EApp. Exp1 ::= Exp1 Exp2 ;
EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ;
EAbs. Exp ::= "\\" Ident "->" Exp ;
EAtom. Exp2 ::= Atom ;
EData. Exp2 ::= "data" ;
-}
convertExp :: [TTerm] -> A.Exp -> TTerm
convertExp args (A.EAtom at) = convertAtom args at
convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
convertExp args exp = error $ "GFCtoSimple.convertExp: " ++ prt exp
convertAtom :: [TTerm] -> A.Atom -> TTerm
convertAtom args (A.AC con) = con :@ reverse args
-- A.AD: is this correct???
convertAtom args (A.AD con) = con :@ args
convertAtom [] (A.AV var) = TVar var
convertAtom args atom = error $ "GFCtoSimple.convertAtom: " ++ prt args ++ " " ++ show atom
convertCat :: A.Atom -> SCat
convertCat (A.AC (A.CIQ _ cat)) = cat
convertCat atom = error $ "GFCtoSimple.convertCat: " ++ show atom
----------------------------------------------------------------------
-- concrete definitions
convertConcrete :: Env -> Abstract SDecl Name -> Concrete SLinType (Maybe STerm)
convertConcrete gram (Abs decl args name) = Cnc ltyp largs term
where term = fmap (convertTerm gram . expandTerm gram) $ lookupLin gram $ name2fun name
ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args)
expandTerm :: Env -> A.Term -> A.Term
expandTerm gram term = -- tracePrt "expanded term" prt $
err error id $ expandLinTables (fst gram) $
-- tracePrt "initial term" prt $
term
convertCType :: Env -> A.CType -> SLinType
convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
convertCType gram (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt)
convertCType gram ct@(A.Cn con) = ConT $ map (convertTerm gram) $ groundTerms gram ct
convertCType gram (A.TStr) = StrT
convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor"
convertTerm :: Env -> A.Term -> STerm
convertTerm gram (A.Arg arg) = convertArgVar arg
convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms
-- convertTerm gram (A.LI var) = Var var
convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ]
convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl
convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
(pat, term) <- zip (groundTerms gram ctype) terms ]
convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) |
A.Cas pats term <- tbl, pat <- pats ]
convertTerm gram (A.S term sel) = convertTerm gram term :! convertTerm gram sel
convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms)
convertTerm gram (A.E) = Empty
convertTerm gram (A.K (A.KS tok)) = Token tok
-- 'pre' tokens are converted to variants (over-generating):
convertTerm gram (A.K (A.KP strs vars))
= variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ]
where conc [] = Empty
conc ts = foldr1 (?++) $ map Token ts
convertTerm gram (A.I con) = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor"
convertTerm gram (A.EInt int) = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor"
convertArgVar :: A.ArgVar -> STerm
convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath
convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath
convertPatt (A.PC con pats) = con :^ map convertPatt pats
-- convertPatt (A.PV x) = Var x
-- convertPatt (A.PW) = Wildcard
convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
convertPatt (A.PI n) = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor"
convertPatt p = error $ "GFCtoSimple.convertPatt: cannot handle " ++ show p
----------------------------------------------------------------------
lookupLin :: Env -> Fun -> Maybe A.Term
lookupLin gram fun = err fail Just $
Look.lookupLin (fst gram) (A.CIQ (snd gram) fun)
lookupCType :: Env -> SDecl -> A.CType
lookupCType env decl
= errVal CMacros.defLinType $
Look.lookupLincat (fst env) (A.CIQ (snd env) (decl2cat decl))
groundTerms :: Env -> A.CType -> [A.Term]
groundTerms gram ctype = err error id $
Look.allParamValues (fst gram) ctype

71
src-3.0/GF/Conversion/Haskell.hs
View File

@@ -1,71 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/08/11 14:11:46 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Converting/Printing different grammar formalisms in Haskell-readable format
-----------------------------------------------------------------------------
module GF.Conversion.Haskell where
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Formalism.MCFG
import GF.Formalism.CFG
import GF.Formalism.Utilities
import GF.Conversion.Types
import GF.Data.Operations ((++++), (+++++))
import GF.Infra.Print
import Data.List (intersperse)
-- | SimpleGFC to Haskell
prtSGrammar :: SGrammar -> String
prtSGrammar rules = "-- Simple GFC grammar as a Haskell file" ++++
"-- Autogenerated from the Grammatical Framework" +++++
"import GF.Formalism.GCFG" ++++
"import GF.Formalism.SimpleGFC" ++++
"import GF.Formalism.Utilities" ++++
"import GF.Canon.AbsGFC (CIdent(..), Label(..))" ++++
"import GF.Infra.Ident (Ident(..))" +++++
"grammar :: SimpleGrammar Ident (NameProfile Ident) String" ++++
"grammar = \n\t[ " ++
concat (intersperse "\n\t, " (map show rules)) ++ "\n\t]\n\n"
-- | MCFG to Haskell
prtMGrammar :: MGrammar -> String
prtMGrammar rules = "-- Multiple context-free grammar as a Haskell file" ++++
"-- Autogenerated from the Grammatical Framework" +++++
"import GF.Formalism.GCFG" ++++
"import GF.Formalism.MCFG" ++++
"import GF.Formalism.Utilities" +++++
"grammar :: MCFGrammar String (NameProfile String) String String" ++++
"grammar = \n\t[ " ++
concat (intersperse "\n\t, " (map prtMRule rules)) ++ "\n\t]\n\n"
where prtMRule (Rule (Abs cat cats (Name fun profiles)) (Cnc lcat lcats lins))
= show (Rule (Abs (prt cat) (map prt cats) (Name (prt fun) (map cnvProfile profiles)))
(Cnc (map prt lcat) (map (map prt) lcats) (map cnvLin lins)))
cnvLin (Lin lbl syms) = Lin (prt lbl) (map (mapSymbol prtMArg id) syms)
prtMArg (cat, lbl, nr) = (prt cat, prt lbl, nr)
-- | CFG to Haskell
prtCGrammar :: CGrammar -> String
prtCGrammar rules = "-- Context-free grammar as a Haskell file" ++++
"-- autogenerated from the Grammatical Framework" +++++
"import GF.Formalism.CFG" ++++
"import GF.Formalism.Utilities" ++++
"\ngrammar :: CFGrammar String (NameProfile String) String" ++++
"grammar = \n\t[ " ++
concat (intersperse "\n\t, " (map prtCRule rules)) ++ "\n\t]\n\n"
where prtCRule (CFRule cat syms (Name fun profiles))
= show (CFRule (prt cat) (map (mapSymbol prt id) syms)
(Name (prt fun) (map cnvProfile profiles)))
cnvProfile (Unify args) = Unify args
cnvProfile (Constant forest) = Constant (fmap prt forest)

53
src-3.0/GF/Conversion/MCFGtoCFG.hs
View File

@@ -1,53 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/09 09:28:43 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- Converting MCFG grammars to (possibly overgenerating) CFG
-----------------------------------------------------------------------------
module GF.Conversion.MCFGtoCFG
(convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import Control.Monad
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Formalism.CFG
import GF.Conversion.Types
----------------------------------------------------------------------
-- * converting (possibly erasing) MCFG grammars
convertGrammar :: EGrammar -> CGrammar
convertGrammar gram = tracePrt "MCFGtoCFG - context-free rules" (prt.length) $
concatMap convertRule gram
convertRule :: ERule -> [CRule]
convertRule (Rule (Abs cat args (Name fun mprofile)) (Cnc _ _ record))
= [ CFRule (CCat cat lbl) rhs (Name fun profile) |
Lin lbl lin <- record,
let rhs = map (mapSymbol convertArg id) lin,
let cprofile = map (Unify . argPlaces lin) [0 .. length args-1],
let profile = mprofile `composeProfiles` cprofile
]
convertArg :: (ECat, ELabel, Int) -> CCat
convertArg (cat, lbl, _) = CCat cat lbl
argPlaces :: [Symbol (cat, lbl, Int) tok] -> Int -> [Int]
argPlaces lin nr = [ place | (nr', place) <- zip linArgs [0..], nr == nr' ]
where linArgs = [ nr' | (_, _, nr') <- filterCats lin ]

51
src-3.0/GF/Conversion/MCFGtoFCFG.hs
View File

@@ -1,51 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/09 09:28:43 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- Converting MCFG grammars to equivalent optimized FCFG
-----------------------------------------------------------------------------
module GF.Conversion.MCFGtoFCFG
(convertGrammar) where
import Control.Monad
import List (elemIndex)
import Array
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Formalism.FCFG
import GF.Conversion.Types
import GF.Data.SortedList (nubsort)
import GF.Infra.Print
----------------------------------------------------------------------
-- * converting MCFG to optimized FCFG
convertGrammar :: MGrammar -> FGrammar
convertGrammar gram = [ FRule (Abs (fcat cat) (map fcat cats) name) (fcnc cnc) |
Rule (Abs cat cats name) cnc <- gram ]
where mcats = nubsort [ mc | Rule (Abs mcat mcats _) _ <- gram, mc <- mcat:mcats ]
fcat mcat@(MCat (ECat scat ecns) mlbls)
= case elemIndex mcat mcats of
Just catid -> FCat catid scat mlbls ecns
Nothing -> error ("MCFGtoFCFG.fcat " ++ prt mcat)
fcnc (Cnc _ arglbls lins) = listArray (0, length lins-1) (map flin lins)
where flin (Lin _ syms) = listArray (0, length syms-1) (map fsym syms)
fsym (Tok tok) = FSymTok tok
fsym (Cat (cat,lbl,arg)) = FSymCat (fcat cat) (flbl arg lbl) arg
flbl arg lbl = case elemIndex lbl (arglbls !! arg) of
Just lblid -> lblid
Nothing -> error ("MCFGtoFCFG.flbl " ++ prt arg ++ " " ++ prt lbl)

205
src-3.0/GF/Conversion/Prolog.hs
View File

@@ -1,205 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/14 09:51:18 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
--
-- Converting/Printing different grammar formalisms in Prolog-readable format
-----------------------------------------------------------------------------
module GF.Conversion.Prolog (prtSGrammar, prtSMulti, prtSHeader, prtSRule,
prtMGrammar, prtMMulti, prtMHeader, prtMRule,
prtCGrammar, prtCMulti, prtCHeader, prtCRule) where
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Formalism.MCFG
import GF.Formalism.CFG
import GF.Formalism.Utilities
import GF.Conversion.Types
import qualified GF.Conversion.GFC as Cnv
import GF.Data.Operations ((++++), (+++++))
import GF.Infra.Print
import qualified GF.Infra.Modules as Mod
import qualified GF.Infra.Option as Option
import GF.Data.Operations (okError)
import GF.Canon.AbsGFC (Flag(..))
import GF.Canon.GFC (CanonGrammar)
import GF.Infra.Ident (Ident(..))
import Data.Maybe (maybeToList, listToMaybe)
import Data.Char (isLower, isAlphaNum)
import GF.System.Tracing
----------------------------------------------------------------------
-- | printing multiple languages at the same time
prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String
prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple "gfc_"
prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg "mcfg_"
prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg "cfg_"
-- code and ideas stolen from GF.CFGM.PrintCFGrammar
prtMulti prtHeader prtRule conversion prefix opts gr
= prtHeader ++++ unlines
[ "\n\n" ++ prtLine ++++
"%% Language module: " ++ prtQ langmod +++++
unlines (map (prtRule langmod) rules) |
lang <- maybe [] (Mod.allConcretes gr) (Mod.greatestAbstract gr),
let Mod.ModMod (Mod.Module{Mod.flags=fs}) = okError (Mod.lookupModule gr lang),
let cnvopts = Option.Opts $ map Option.gfcConversion $ getFlag fs "conversion",
let rules = conversion cnvopts (gr, lang),
let langmod = (let IC lg = lang in prefix ++ lg) ]
getFlag :: [Flag] -> String -> [String]
getFlag fs x = [v | Flg (IC k) (IC v) <- fs, k == x]
----------------------------------------------------------------------
-- | SimpleGFC to Prolog
--
-- assumes that the profiles in the Simple GFC names are trivial
prtSGrammar :: SGrammar -> String
prtSGrammar rules = prtSHeader +++++ unlines (map (prtSRule "") rules)
prtSHeader :: String
prtSHeader = prtLine ++++
"%% Simple GFC grammar in Prolog-readable format" ++++
"%% Autogenerated from the Grammatical Framework" +++++
"%% The following predicate is defined:" ++++
"%% \t rule(Fun, Cat, c(Cat,...), LinTerm)"
prtSRule :: String -> SRule -> String
prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm))
= (if null lang then "" else prtQ lang ++ " : ") ++
prtFunctor "rule" [plfun, plcat, plcats, plcnc] ++ "."
where plfun = prtQ fun
plcat = prtSDecl cat
plcats = prtFunctor "c" (map prtSDecl cats)
plcnc = "\n\t" ++ prtSTerm (maybe Empty id mterm)
prtSTerm (Arg n c p) = prtFunctor "arg" [prtQ c, prt (n+1), prtSPath p]
-- prtSTerm (c :^ []) = prtQ c
prtSTerm (c :^ ts) = prtOper "^" (prtQ c) (prtPList (map prtSTerm ts))
prtSTerm (Rec rec) = prtFunctor "rec" [prtPList [ prtOper "=" (prtQ l) (prtSTerm t) | (l, t) <- rec ]]
prtSTerm (Tbl tbl) = prtFunctor "tbl" [prtPList [ prtOper "=" (prtSTerm p) (prtSTerm t) | (p, t) <- tbl ]]
prtSTerm (Variants ts) = prtFunctor "variants" [prtPList (map prtSTerm ts)]
prtSTerm (t1 :++ t2) = prtOper "+" (prtSTerm t1) (prtSTerm t2)
prtSTerm (Token t) = prtFunctor "tok" [prtQ t]
prtSTerm (Empty) = "empty"
prtSTerm (term :. lbl) = prtOper "*" (prtSTerm term) (prtQ lbl)
prtSTerm (term :! sel) = prtOper "/" (prtSTerm term) (prtSTerm sel)
-- prtSTerm (Wildcard) = "wildcard"
-- prtSTerm (Var var) = prtFunctor "var" [prtQ var]
prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path)
prtSDecl (Decl var typ) | var == anyVar = prtSAbsType typ
| otherwise = "_" ++ prtVar var ++ ":" ++ prtSAbsType typ
prtSAbsType ([] ::--> typ) = prtSFOType typ
prtSAbsType (args ::--> typ) = prtOper ":->" (prtPList (map prtSFOType args)) (prtSFOType typ)
prtSFOType (cat ::@ args) = prtFunctor (prtQ cat) (map prtSTTerm args)
prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args)
prtSTTerm (TVar var) = "_" ++ prtVar var
----------------------------------------------------------------------
-- | MCFG to Prolog
prtMGrammar :: MGrammar -> String
prtMGrammar rules = prtMHeader +++++ unlines (map (prtMRule "") rules)
prtMHeader :: String
prtMHeader = prtLine ++++
"%% Multiple context-free grammar in Prolog-readable format" ++++
"%% Autogenerated from the Grammatical Framework" +++++
"%% The following predicate is defined:" ++++
"%% \t rule(Profile, Cat, c(Cat,...), [Lbl=Symbols,...])"
prtMRule :: String -> MRule -> String
prtMRule lang (Rule (Abs cat cats name) (Cnc _lcat _lcats lins))
= (if null lang then "" else prtQ lang ++ " : ") ++
prtFunctor "rule" [plname, plcat, plcats, pllins] ++ "."
where plname = prtName name
plcat = prtQ cat
plcats = prtFunctor "c" (map prtQ cats)
pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]"
prtMLin (Lin lbl lin) = prtOper "=" (prtQ lbl) (prtPList (map prtMSymbol lin))
prtMSymbol (Cat (cat, lbl, nr)) = prtFunctor "arg" [prtQ cat, show (nr+1), prtQ lbl]
prtMSymbol (Tok tok) = prtFunctor "tok" [prtQ tok]
----------------------------------------------------------------------
-- | CFG to Prolog
prtCGrammar :: CGrammar -> String
prtCGrammar rules = prtCHeader +++++ unlines (map (prtCRule "") rules)
prtCHeader :: String
prtCHeader = prtLine ++++
"%% Context-free grammar in Prolog-readable format" ++++
"%% Autogenerated from the Grammatical Framework" +++++
"%% The following predicate is defined:" ++++
"%% \t rule(Profile, Cat, [Symbol,...])"
prtCRule :: String -> CRule -> String
prtCRule lang (CFRule cat syms name)
= (if null lang then "" else prtQ lang ++ " : ") ++
prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "."
where plname = prtName name
plcat = prtQ cat
plsyms = prtPList (map prtCSymbol syms)
prtCSymbol (Cat cat) = prtFunctor "cat" [prtQ cat]
prtCSymbol (Tok tok) = prtFunctor "tok" [prtQ tok]
----------------------------------------------------------------------
-- profiles, quoted strings and more
prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")"
prtPList xs = "[" ++ prtSep ", " xs ++ "]"
prtOper f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")"
prtName name@(Name fun profiles)
| name == coercionName = "1"
| and (zipWith (==) profiles (map (Unify . return) [0..])) = prtQ fun
| otherwise = prtFunctor (prtQ fun) (map prtProfile profiles)
prtProfile (Unify []) = " ? "
prtProfile (Unify args) = foldr1 (prtOper "=") (map (show . succ) args)
prtProfile (Constant forest) = prtForest forest
prtForest (FMeta) = " ? "
prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (map prtForest fs)
prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (map prtForest fs) |
fs <- fss ]
prtQ atom = prtQStr (prt atom)
prtQStr atom@(x:xs)
| isLower x && all isAlphaNumUnder xs = atom
where isAlphaNumUnder '_' = True
isAlphaNumUnder x = isAlphaNum x
prtQStr atom = "'" ++ concatMap esc (prt atom) ++ "'"
where esc '\'' = "\\'"
esc '\n' = "\\n"
esc '\t' = "\\t"
esc c = [c]
prtVar var = reprime (prt var)
where reprime "" = ""
reprime ('\'' : cs) = "_0" ++ reprime cs
reprime (c:cs) = c : reprime cs
prtLine = replicate 70 '%'

46
src-3.0/GF/Conversion/RemoveEpsilon.hs
View File

@@ -1,46 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 08:11:32 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- Removing epsilon linearizations from MCF grammars
-----------------------------------------------------------------------------
module GF.Conversion.RemoveEpsilon where
-- (convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import Control.Monad
import Data.List (mapAccumL)
import Data.Maybe (mapMaybe)
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Conversion.Types
import GF.Data.Assoc
import GF.Data.SortedList
import GF.Data.GeneralDeduction
convertGrammar :: EGrammar -> EGrammar
convertGrammar grammar = trace2 "RemoveEpsilon: initialEmpties" (prt initialEmpties) $
trace2 "RemoveEpsilon: emptyCats" (prt emptyCats) $
grammar
where initialEmpties = nubsort [ (cat, lbl) |
Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar,
Lin lbl [] <- lins ]
emptyCats = limitEmpties initialEmpties
limitEmpties es = if es==es' then es else limitEmpties es'
where es' = nubsort [ (cat, lbl) | Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar,
Lin lbl rhs <- lins,
all (symbol (\(c,l,n) -> (c,l) `elem` es) (const False)) rhs ]

113
src-3.0/GF/Conversion/RemoveErasing.hs
View File

@@ -1,113 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/09 09:28:44 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1)
-----------------------------------------------------------------------------
module GF.Conversion.RemoveErasing
(convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import Control.Monad
import Data.List (mapAccumL)
import Data.Maybe (mapMaybe)
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Conversion.Types
import GF.Data.Assoc
import GF.Data.SortedList
import GF.Data.GeneralDeduction
convertGrammar :: EGrammar -> [SCat] -> MGrammar
convertGrammar grammar starts = newGrammar
where newGrammar = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $
[ rule | NR rule <- chartLookup finalChart True ]
finalChart = tracePrt "RemoveErasing - nonerasing cats"
(prt . length . flip chartLookup False) $
buildChart keyof [newRules rulesByCat] $
tracePrt "RemoveErasing - initial ne-cats" (prt . length) $
initialCats
initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $
if null starts
then trace2 "RemoveErasing" "initialCatsBU" $
initialCatsBU rulesByCat
else trace2 "RemoveErasing" ("initialCatsTD: " ++ prt starts) $
initialCatsTD rulesByCat starts
rulesByCat = trace2 "RemoveErasing - erasing rules" (prt $ length grammar) $
accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ]
data Item r c = NR r | NC c deriving (Eq, Ord, Show)
keyof (NR _) = True
keyof (NC _) = False
newRules grammar chart (NR (Rule (Abs _ cats _) _))
= [ NC cat | cat@(MCat _ lbls) <- cats, not (null lbls) ]
newRules grammar chart (NC newCat@(MCat cat lbls))
= do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat
lins <- selectLins lins0 lbls
-- let lins = [ lin | lin@(Lin lbl _) <- lins0,
-- lbl `elem` lbls ]
let argsInLin = listAssoc $
map (\((n,c),l) -> (n, MCat c l)) $
groupPairs $ nubsort $
[ ((nr, cat), lbl) |
Lin _ lin <- lins,
Cat (cat, lbl, nr) <- lin ]
newArgs = mapMaybe (lookupAssoc argsInLin) [0 .. length args-1]
argLbls = [ lbls | MCat _ lbls <- newArgs ]
newLins = [ Lin lbl newLin | Lin lbl lin <- lins,
let newLin = map (mapSymbol cnvCat id) lin ]
cnvCat (cat, lbl, nr) = (mcat, lbl, nr')
where Just mcat = lookupAssoc argsInLin nr
Unify [nr'] = newProfile !! nr
nonEmptyCat (Cat (MCat _ [], _, _)) = False
nonEmptyCat _ = True
newProfile = snd $ mapAccumL accumProf 0 $
map (lookupAssoc argsInLin) [0 .. length args-1]
accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr])
newName = -- tracePrt "newName" (prtNewName profile newProfile) $
Name fun (profile `composeProfiles` newProfile)
guard $ all (not . null) argLbls
return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
selectLins lins0 = mapM selectLbl
where selectLbl lbl = [ lin | lin@(Lin lbl' _) <- lins0, lbl == lbl' ]
prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String
prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n
initialCatsTD grammar starts =
[ cat | cat@(NC (MCat (ECat start _) _)) <- initialCatsBU grammar,
start `elem` starts ]
initialCatsBU grammar
= [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar,
let Rule _ (Cnc lbls _ _) = head rules,
lbl <- lbls ]

82
src-3.0/GF/Conversion/RemoveSingletons.hs
View File

@@ -1,82 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/11 10:28:16 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Instantiating all types which only have one single element.
--
-- Should be merged into 'GF.Conversion.FiniteToSimple'
-----------------------------------------------------------------------------
module GF.Conversion.RemoveSingletons where
import GF.System.Tracing
import GF.Infra.Print
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Conversion.Types
import GF.Data.SortedList
import GF.Data.Assoc
import Data.List (mapAccumL)
convertGrammar :: SGrammar -> SGrammar
convertGrammar grammar = if singles == emptyAssoc then grammar
else tracePrt "RemoveSingletons - non-singleton rules" (prt . length) $
map (convertRule singles) grammar
where singles = calcSingletons grammar
convertRule :: Assoc SCat (SyntaxForest Fun, Maybe STerm) -> SRule -> SRule
convertRule singles rule@(Rule (Abs _ decls _) _)
= if all (Nothing ==) singleArgs then rule
else instantiateSingles singleArgs rule
where singleArgs = map (lookupAssoc singles . decl2cat) decls
instantiateSingles :: [Maybe (SyntaxForest Fun, Maybe STerm)] -> SRule -> SRule
instantiateSingles singleArgs (Rule (Abs decl decls (Name fun profile)) (Cnc lcat lcats lterm))
= Rule (Abs decl decls' (Name fun profile')) (Cnc lcat lcats' lterm')
where (decls', lcats') = unzip [ (d, l) | (Nothing, d, l) <- zip3 singleArgs decls lcats ]
profile' = map (fmap fst) exProfile `composeProfiles` profile
newArgs = map (fmap snd) exProfile
lterm' = fmap (instantiateLin newArgs) lterm
exProfile = snd $ mapAccumL mkProfile 0 singleArgs
mkProfile nr (Just trm) = (nr, Constant trm)
mkProfile nr (Nothing) = (nr+1, Unify [nr])
instantiateLin :: [Profile (Maybe STerm)] -> STerm -> STerm
instantiateLin newArgs = inst
where inst (Arg nr cat path)
= case newArgs !! nr of
Unify [nr'] -> Arg nr' cat path
Constant (Just term) -> termFollowPath path term
Constant Nothing -> error "RemoveSingletons.instantiateLin: This should not happen (argument has no linearization)"
inst (cn :^ terms) = cn :^ map inst terms
inst (Rec rec) = Rec [ (lbl, inst term) | (lbl, term) <- rec ]
inst (term :. lbl) = inst term +. lbl
inst (Tbl tbl) = Tbl [ (pat, inst term) | (pat, term) <- tbl ]
inst (term :! sel) = inst term +! inst sel
inst (Variants ts) = variants (map inst ts)
inst (t1 :++ t2) = inst t1 ?++ inst t2
inst term = term
----------------------------------------------------------------------
calcSingletons :: SGrammar -> Assoc SCat (SyntaxForest Fun, Maybe STerm)
calcSingletons rules = listAssoc singleCats
where singleCats = tracePrt "RemoveSingletons - singleton cats" (prtSep " ") $
[ (cat, (constantNameToForest name, lin)) |
(cat, [([], name, lin)]) <- rulesByCat ]
rulesByCat = groupPairs $ nubsort
[ (decl2cat cat, (args, name, lin)) |
Rule (Abs cat args name) (Cnc _ _ lin) <- rules ]

178
src-3.0/GF/Conversion/SimpleToFinite.hs
View File

@@ -1,178 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/01 09:53:19 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- Calculating the finiteness of each type in a grammar
-----------------------------------------------------------------------------
module GF.Conversion.SimpleToFinite
(convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Formalism.Utilities
import GF.Conversion.Types
import GF.Data.SortedList
import GF.Data.Assoc
import GF.Data.BacktrackM
import GF.Data.Utilities (lookupList)
import GF.Infra.Ident (Ident(..))
type CnvMonad a = BacktrackM () a
convertGrammar :: SGrammar -> SGrammar
convertGrammar rules = tracePrt "SimpleToFinie - nr. 'finite' rules" (prt . length) $
solutions cnvMonad ()
where split = calcSplitable rules
cnvMonad = member rules >>= convertRule split
convertRule :: Splitable -> SRule -> CnvMonad SRule
convertRule split (Rule abs cnc)
= do newAbs <- convertAbstract split abs
return $ Rule newAbs cnc
{-
-- old code
convertAbstract :: Splitable -> Abstract SDecl Name
-> CnvMonad (Abstract SDecl Name)
convertAbstract split (Abs decl decls name)
= case splitableFun split (name2fun name) of
Just cat' -> return $ Abs (Decl anyVar (mergeFun (name2fun name) cat') []) decls name
Nothing -> expandTyping split name [] decl decls []
expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl]
-> CnvMonad (Abstract SDecl Name)
expandTyping split name env (Decl x cat args) [] decls
= return $ Abs decl (reverse decls) name
where decl = substArgs split x env cat args []
expandTyping split name env typ (Decl x xcat xargs : declsToDo) declsDone
= do (x', xcat', env') <- calcNewEnv
let decl = substArgs split x' env xcat' xargs []
expandTyping split name env' typ declsToDo (decl : declsDone)
where calcNewEnv = case splitableCat split xcat of
Just newFuns -> do newFun <- member newFuns
let newCat = mergeFun newFun xcat
-- Just newCats -> do newCat <- member newCats
return (anyVar, newCat, (x,newCat) : env)
Nothing -> return (x, xcat, env)
-}
-- new code
convertAbstract :: Splitable -> Abstract SDecl Name
-> CnvMonad (Abstract SDecl Name)
convertAbstract split (Abs decl decls name)
= case splitableFun split fun of
Just cat' -> return $ Abs (Decl anyVar ([] ::--> (mergeFun fun cat' ::@ []))) decls name
Nothing -> expandTyping split [] fun profiles [] decl decls []
where Name fun profiles = name
expandTyping :: Splitable -> [(Var, SCat)]
-> Fun -> [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)]
-> SDecl -> [SDecl] -> [SDecl]
-> CnvMonad (Abstract SDecl Name)
expandTyping split env fun [] profiles (Decl x (typargs ::--> (cat ::@ args))) [] decls
= return $ Abs decl (reverse decls) (Name fun (reverse profiles))
where decl = substArgs split x env typargs cat args []
expandTyping split env fun (prof:profiles) profsDone typ
(Decl x (xtypargs ::--> (xcat ::@ xargs)) : declsToDo) declsDone
= do (x', xcat', env', prof') <- calcNewEnv
let decl = substArgs split x' env xtypargs xcat' xargs []
expandTyping split env' fun profiles (prof' : profsDone) typ declsToDo (decl : declsDone)
where calcNewEnv = case splitableCat split xcat of
Nothing -> return (x, xcat, env, prof)
Just newFuns -> do newFun <- member newFuns
let newCat = mergeFun newFun xcat
newProf = Constant (FNode newFun [[]])
-- should really be using some kind of
-- "profile unification"
return (anyVar, newCat, (x,newCat) : env, newProf)
substArgs :: Splitable -> Var -> [(Var, SCat)] -> [FOType SCat]
-> SCat -> [TTerm] -> [TTerm] -> SDecl
substArgs split x env typargs cat [] args = Decl x (typargs ::--> (cat ::@ reverse args))
substArgs split x env typargs cat (arg:argsToDo) argsDone
= case argLookup split env arg of
Just newCat -> substArgs split x env typargs (mergeArg cat newCat) argsToDo argsDone
Nothing -> substArgs split x env typargs cat argsToDo (arg : argsDone)
argLookup split env (TVar x) = lookup x env
argLookup split env (con :@ _) = fmap (mergeFun fun) (splitableFun split fun)
where fun = constr2fun con
----------------------------------------------------------------------
-- splitable categories (finite, no dependencies)
-- they should also be used as some dependency
type Splitable = (Assoc SCat [Fun], Assoc Fun SCat)
splitableCat :: Splitable -> SCat -> Maybe [Fun]
splitableCat = lookupAssoc . fst
splitableFun :: Splitable -> Fun -> Maybe SCat
splitableFun = lookupAssoc . snd
calcSplitable :: [SRule] -> Splitable
calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
where splitableCat2Funs = groupPairs $ nubsort splitableCatFuns
splitableFun2Cat = nubsort
[ (fun, cat) | (cat, fun) <- splitableCatFuns ]
-- cat-fun pairs that are splitable
splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $
[ (cat, name2fun name) |
Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] name) _ <- rules,
splitableCats ?= cat ]
-- all cats that are splitable
splitableCats = listSet $
tracePrt "SimpleToFinite - finite categories to split" prt $
(nondepCats <**> depCats) <\\> resultCats
-- all result cats for some pure function
resultCats = tracePrt "SimpleToFinite - result cats" prt $
nubsort [ cat | Rule (Abs (Decl _ (_ ::--> (cat ::@ _))) decls _) _ <- rules,
not (null decls) ]
-- all cats in constants without dependencies
nondepCats = tracePrt "SimpleToFinite - nondep cats" prt $
nubsort [ cat | Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] _) _ <- rules ]
-- all cats occurring as some dependency of another cat
depCats = tracePrt "SimpleToFinite - dep cats" prt $
nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
cat <- varCats [] (decls ++ [decl]) ]
varCats _ [] = []
varCats env (Decl x (xargs ::--> xtyp@(xcat ::@ _)) : decls)
= varCats ((x,xcat) : env) decls ++
[ cat | (_::@args) <- (xtyp:xargs), arg <- args,
y <- varsInTTerm arg, cat <- lookupList y env ]
----------------------------------------------------------------------
-- utilities
-- mergeing categories
mergeCats :: String -> String -> String -> SCat -> SCat -> SCat
mergeCats before middle after (IC cat) (IC arg)
= IC (before ++ cat ++ middle ++ arg ++ after)
mergeFun, mergeArg :: SCat -> SCat -> SCat
mergeFun = mergeCats "{" ":" "}"
mergeArg = mergeCats "" "" ""

26
src-3.0/GF/Conversion/SimpleToMCFG.hs
View File

@@ -1,26 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/18 14:55:32 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- All different conversions from SimpleGFC to MCFG
-----------------------------------------------------------------------------
module GF.Conversion.SimpleToMCFG where
import GF.Formalism.SimpleGFC
import GF.Conversion.Types
import qualified GF.Conversion.SimpleToMCFG.Strict as Strict
import qualified GF.Conversion.SimpleToMCFG.Nondet as Nondet
import qualified GF.Conversion.SimpleToMCFG.Coercions as Coerce
convertGrammarNondet, convertGrammarStrict :: SGrammar -> EGrammar
convertGrammarNondet = Coerce.addCoercions . Nondet.convertGrammar
convertGrammarStrict = Strict.convertGrammar

63
src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs
View File

@@ -1,63 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/09 09:28:44 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Adding coercion functions to a MCFG if necessary.
-----------------------------------------------------------------------------
module GF.Conversion.SimpleToMCFG.Coercions
(addCoercions) where
import GF.System.Tracing
import GF.Infra.Print
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Conversion.Types
import GF.Data.SortedList
import Data.List (groupBy)
----------------------------------------------------------------------
addCoercions :: EGrammar -> EGrammar
addCoercions rules = coercions ++ rules
where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) |
Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
allHeadSet = nubsort allHeads
allArgSet = union allArgs <\\> map fst allHeadSet
coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $
concat $
tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category"
(prtList . map length) $
combineCoercions
(groupBy sameECatFst allHeadSet)
(groupBy sameECat allArgSet)
sameECatFst a b = sameECat (fst a) (fst b)
combineCoercions [] _ = []
combineCoercions _ [] = []
combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs)
= case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of
LT -> combineCoercions allHeads allArgs'
GT -> combineCoercions allHeads' allArgs
EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
makeCoercion heads args
= [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins) |
(head@(ECat _ headCns), lbls) <- heads,
let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
arg@(ECat _ argCns) <- args,
argCns `subset` headCns ]

256
src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs
View File

@@ -1,256 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/08/17 08:27:29 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
--
-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
-- Afterwards, the grammar has to be extended with coercion functions,
-- from the module 'GF.Conversion.SimpleToMCFG.Coercions'
--
-- the resulting grammars might be /very large/
--
-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
-----------------------------------------------------------------------------
module GF.Conversion.SimpleToMCFG.Nondet
(convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import Control.Monad
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Formalism.SimpleGFC
import GF.Conversion.Types
import GF.Data.BacktrackM
import GF.Data.Utilities (notLongerThan, updateNthM)
------------------------------------------------------------
-- type declarations
type CnvMonad a = BacktrackM Env a
type Env = (ECat, [ECat], LinRec, [SLinType]) -- variable bindings: [(Var, STerm)]
type LinRec = [Lin SCat MLabel Token]
----------------------------------------------------------------------
-- main conversion function
maxNrRules :: Int
maxNrRules = 5000
convertGrammar :: SGrammar -> EGrammar
convertGrammar rules = traceCalcFirst rules' $
tracePrt "SimpleToMCFG.Nondet - MCFG rules" (prt . length) $
rules'
where rules' = rules >>= convertRule
-- solutions conversion undefined
-- where conversion = member rules >>= convertRule
convertRule :: SRule -> [ERule] -- CnvMonad ERule
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) =
-- | prt(name2fun fun) `elem`
-- words "UseCl PosTP TPast ASimul SPredV IndefOneNP DefOneNP UseN2 mother_N2 jump_V" =
if notLongerThan maxNrRules rules
then tracePrt ("SimpeToMCFG.Nondet - MCFG rules for " ++ prt fun) (prt . length) $
rules
else trace2 "SimpeToMCFG.Nondet - TOO MANY RULES, function not converted"
("More than " ++ show maxNrRules ++ " MCFG rules for " ++ prt fun) $
[]
where rules = flip solutions undefined $
do let cat : args = map decl2cat (decl : decls)
writeState (initialECat cat, map initialECat args, [], ctypes)
rterm <- simplifyTerm term
reduceTerm ctype emptyPath rterm
(newCat, newArgs, linRec, _) <- readState
let newLinRec = map (instantiateArgs newArgs) linRec
catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
-- checkLinRec argsPaths catPaths newLinRec
return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec)
convertRule _ = [] -- failure
----------------------------------------------------------------------
-- "type-checking" the resulting linearization
-- should not be necessary, if the algorithms (type-checking and conversion) are correct
checkLinRec args lbls = mapM (checkLin args lbls)
checkLin args lbls (Lin lbl lin)
| lbl `elem` lbls = mapM (symbol (checkArg args) (const (return ()))) lin
| otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" "Label mismatch" $
failure
checkArg args (_cat, lbl, nr)
| lbl `elem` (args !! nr) = return ()
-- | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" ("Label mismatch in arg " ++ prt nr) $
-- failure
| otherwise = trace2 ("SimpleToMCFG.Nondet - ERROR: Label mismatch in arg " ++ prt nr)
(prt lbl ++ " `notElem` " ++ prt (args!!nr)) $
failure
----------------------------------------------------------------------
-- term simplification
simplifyTerm :: STerm -> CnvMonad STerm
simplifyTerm (term :! sel)
= do sterm <- simplifyTerm term
ssel <- simplifyTerm sel
case sterm of
Tbl table -> do (pat, val) <- member table
pat =?= ssel
return val
_ -> do sel' <- expandTerm ssel
return (sterm +! sel')
-- simplifyTerm (Var x) = readBinding x
simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms
simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record
simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term
simplifyTerm (Tbl table) = liftM Tbl $ mapM simplifyCase table
simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms
simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
simplifyTerm term = return term
simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term
simplifyCase :: (STerm, STerm) -> CnvMonad (STerm, STerm)
simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term)
------------------------------------------------------------
-- reducing simplified terms, collecting MCF rules
reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad ()
--reduceTerm ctype path (Variants terms)
-- = member terms >>= reduceTerm ctype path
reduceTerm (StrT) path term = updateLin (path, term)
reduceTerm (ConT _) path term = do pat <- expandTerm term
updateHead (path, pat)
reduceTerm (RecT rtype) path term
= sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) | (lbl, ctype) <- rtype ]
reduceTerm (TblT pats vtype) path table
= sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | pat <- pats ]
------------------------------------------------------------
-- expanding a term to ground terms
expandTerm :: STerm -> CnvMonad STerm
expandTerm arg@(Arg nr _ path)
= do ctypes <- readArgCTypes
unifyPType arg $ lintypeFollowPath path $ ctypes !! nr
-- expandTerm arg@(Arg nr _ path)
-- = do ctypes <- readArgCTypes
-- pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
-- pat =?= arg
-- return pat
expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms
expandTerm (Rec record) = liftM Rec $ mapM expandAssign record
--expandTerm (Variants terms) = liftM Variants $ mapM expandTerm terms
expandTerm (Variants terms) = member terms >>= expandTerm
expandTerm term = error $ "expandTerm: " ++ prt term
expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
unifyPType :: STerm -> SLinType -> CnvMonad STerm
unifyPType arg (RecT prec) =
liftM Rec $
sequence [ liftM ((,) lbl) $
unifyPType (arg +. lbl) ptype |
(lbl, ptype) <- prec ]
unifyPType (Arg nr _ path) (ConT terms) =
do (_, args, _, _) <- readState
case lookup path (ecatConstraints (args !! nr)) of
Just term -> return term
Nothing -> do term <- member terms
updateArg nr (path, term)
return term
------------------------------------------------------------
-- unification of patterns and selection terms
(=?=) :: STerm -> STerm -> CnvMonad ()
-- Wildcard =?= _ = return ()
-- Var x =?= term = addBinding x term
Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
(lbl, pat) <- precord ]
pat =?= Arg nr _ path = updateArg nr (path, pat)
(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms)
sequence_ $ zipWith (=?=) pats terms
Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm |
(lbl, pat) <- precord,
let mterm = lookup lbl record ]
-- variants are not allowed in patterns, but in selection terms:
term =?= Variants terms = member terms >>= (term =?=)
pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term
----------------------------------------------------------------------
-- variable bindings (does not work correctly)
{-
addBinding x term = do (a, b, c, d, bindings) <- readState
writeState (a, b, c, d, (x,term):bindings)
readBinding x = do (_, _, _, _, bindings) <- readState
return $ maybe (Var x) id $ lookup x bindings
-}
------------------------------------------------------------
-- updating the MCF rule
readArgCTypes :: CnvMonad [SLinType]
readArgCTypes = do (_, _, _, env) <- readState
return env
updateArg :: Int -> Constraint -> CnvMonad ()
updateArg arg cn
= do (head, args, lins, env) <- readState
args' <- updateNthM (addToECat cn) arg args
writeState (head, args', lins, env)
updateHead :: Constraint -> CnvMonad ()
updateHead cn
= do (head, args, lins, env) <- readState
head' <- addToECat cn head
writeState (head', args, lins, env)
updateLin :: Constraint -> CnvMonad ()
updateLin (path, term)
= do let newLins = term2lins term
(head, args, lins, env) <- readState
let lins' = lins ++ map (Lin path) newLins
writeState (head, args, lins', env)
term2lins :: STerm -> [[Symbol (SCat, SPath, Int) Token]]
term2lins (Arg nr cat path) = return [Cat (cat, path, nr)]
term2lins (Token str) = return [Tok str]
term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2)
term2lins (Empty) = return []
term2lins (Variants terms) = terms >>= term2lins
term2lins term = error $ "term2lins: " ++ show term
addToECat :: Constraint -> ECat -> CnvMonad ECat
addToECat cn (ECat cat cns) = liftM (ECat cat) $ addConstraint cn cns
addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint]
addConstraint cn0 (cn : cns)
| fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns)
| fst cn0 == fst cn = guard (snd cn0 == snd cn) >>
return (cn : cns)
addConstraint cn0 cns = return (cn0 : cns)

129
src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs
View File

@@ -1,129 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/09 09:28:44 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Converting SimpleGFC grammars to MCFG grammars, deterministic.
--
-- the resulting grammars might be /very large/
--
-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
-----------------------------------------------------------------------------
module GF.Conversion.SimpleToMCFG.Strict
(convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import Control.Monad
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Formalism.SimpleGFC
import GF.Conversion.Types
import GF.Data.BacktrackM
import GF.Data.SortedList
----------------------------------------------------------------------
-- main conversion function
type CnvMonad a = BacktrackM () a
convertGrammar :: SGrammar -> EGrammar
convertGrammar rules = tracePrt "SimpleToMCFG.Strict - MCFG rules" (prt . length) $
solutions conversion undefined
where conversion = member rules >>= convertRule
convertRule :: SRule -> CnvMonad ERule
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
= do let cat : args = map decl2cat (decl : decls)
args_ctypes = zip3 [0..] args ctypes
instArgs <- mapM enumerateArg args_ctypes
let instTerm = substitutePaths instArgs term
newCat <- extractECat cat ctype instTerm
newArgs <- mapM (extractArg instArgs) args_ctypes
let linRec = strPaths ctype instTerm >>= extractLin newArgs
let newLinRec = map (instantiateArgs newArgs) linRec
catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec)
convertRule _ = failure
----------------------------------------------------------------------
-- category extraction
extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad ECat
extractArg args (nr, cat, ctype) = extractECat cat ctype (args !! nr)
extractECat :: SCat -> SLinType -> STerm -> CnvMonad ECat
extractECat cat ctype term = member $ map (ECat cat) $ parPaths ctype term
enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm
enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype
----------------------------------------------------------------------
-- Substitute each instantiated parameter path for its instantiation
substitutePaths :: [STerm] -> STerm -> STerm
substitutePaths arguments = subst
where subst (Arg nr _ path) = termFollowPath path (arguments !! nr)
subst (con :^ terms) = con :^ map subst terms
subst (Rec record) = Rec [ (lbl, subst term) | (lbl, term) <- record ]
subst (term :. lbl) = subst term +. lbl
subst (Tbl table) = Tbl [ (pat, subst term) |
(pat, term) <- table ]
subst (term :! select) = subst term +! subst select
subst (term :++ term') = subst term ?++ subst term'
subst (Variants terms) = Variants $ map subst terms
subst term = term
----------------------------------------------------------------------
-- term paths extaction
termPaths :: SLinType -> STerm -> [(SPath, (SLinType, STerm))]
termPaths ctype (Variants terms) = terms >>= termPaths ctype
termPaths (RecT rtype) (Rec record)
= [ (path ++. lbl, value) |
(lbl, term) <- record,
let Just ctype = lookup lbl rtype,
(path, value) <- termPaths ctype term ]
termPaths (TblT _ ctype) (Tbl table)
= [ (path ++! pat, value) |
(pat, term) <- table,
(path, value) <- termPaths ctype term ]
termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ]
{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt):
{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2}
[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2]
-}
parPaths :: SLinType -> STerm -> [[(SPath, STerm)]]
parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $
nubsort [ (path, value) |
(path, (ConT _, value)) <- termPaths ctype term ]
strPaths :: SLinType -> STerm -> [(SPath, STerm)]
strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ]
where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ]
----------------------------------------------------------------------
-- linearization extraction
extractLin :: [ECat] -> (SPath, STerm) -> [Lin ECat MLabel Token]
extractLin args (path, term) = map (Lin path) (convertLin term)
where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2)
convertLin (Empty) = [[]]
convertLin (Token tok) = [[Tok tok]]
convertLin (Variants terms) = concatMap convertLin terms
convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]]
convertLin t = error $ "convertLin: " ++ prt t ++ " " ++ prt (args, path)

58
src-3.0/GF/Conversion/TypeGraph.hs
View File

@@ -1,58 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/16 10:21:21 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
--
-- Printing the type hierarchy of an abstract module in GraphViz format
-----------------------------------------------------------------------------
module GF.Conversion.TypeGraph (prtTypeGraph, prtFunctionGraph) where
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Formalism.Utilities
import GF.Conversion.Types
import GF.Data.Operations ((++++), (+++++))
import GF.Infra.Print
----------------------------------------------------------------------
-- | SimpleGFC to TypeGraph
--
-- assumes that the profiles in the Simple GFC names are trivial
prtTypeGraph :: SGrammar -> String
prtTypeGraph rules = "digraph TypeGraph {" ++++
"concentrate=true;" ++++
"node [shape=ellipse];" +++++
unlines (map prtTypeGraphRule rules) +++++
"}"
prtTypeGraphRule :: SRule -> String
prtTypeGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _)
= "// " ++ prt abs ++++
unlines [ prtSCat c ++ " -> " ++ prtSCat cat ++ ";" | c <- cats ]
prtFunctionGraph :: SGrammar -> String
prtFunctionGraph rules = "digraph FunctionGraph {" ++++
"node [shape=ellipse];" +++++
unlines (map prtFunctionGraphRule rules) +++++
"}"
prtFunctionGraphRule :: SRule -> String
prtFunctionGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _)
= "// " ++ prt abs ++++
pfun ++ " [label=\"" ++ prt fun ++ "\", shape=box, style=dashed];" ++++
pfun ++ " -> " ++ prtSCat cat ++ ";" ++++
unlines [ prtSCat c ++ " -> " ++ pfun ++ ";" | c <- cats ]
where pfun = "GF_FUNCTION_" ++ prt fun
prtSCat decl = prt (decl2cat decl)

146
src-3.0/GF/Conversion/Types.hs
View File

@@ -1,146 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/08/11 14:11:46 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.10 $
--
-- All possible instantiations of different grammar formats used in conversion from GFC
-----------------------------------------------------------------------------
module GF.Conversion.Types where
---import GF.Conversion.FTypes
import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
import qualified GF.GFCC.CId
import qualified GF.Grammar.Grammar as Grammar (Term)
import GF.Formalism.GCFG
import GF.Formalism.SimpleGFC
import GF.Formalism.MCFG
import GF.Formalism.FCFG
import GF.Formalism.CFG
import GF.Formalism.Utilities
import GF.Infra.Print
import GF.Data.Assoc
import Control.Monad (foldM)
import Data.Array
----------------------------------------------------------------------
-- * basic (leaf) types
-- ** input tokens
type Token = String
-- ** function names
type Fun = Ident.Ident
type Name = NameProfile Fun
----------------------------------------------------------------------
-- * Simple GFC
type SCat = Ident.Ident
constr2fun :: Constr -> Fun
constr2fun (AbsGFC.CIQ _ fun) = fun
-- ** grammar types
type SGrammar = SimpleGrammar SCat Name Token
type SRule = SimpleRule SCat Name Token
type SPath = Path SCat Token
type STerm = Term SCat Token
type SLinType = LinType SCat Token
type SDecl = Decl SCat
----------------------------------------------------------------------
-- * erasing MCFG
type EGrammar = MCFGrammar ECat Name ELabel Token
type ERule = MCFRule ECat Name ELabel Token
data ECat = ECat SCat [Constraint] deriving (Eq, Ord, Show)
type ELabel = SPath
type Constraint = (SPath, STerm)
-- ** type coercions etc
initialECat :: SCat -> ECat
initialECat cat = ECat cat []
ecat2scat :: ECat -> SCat
ecat2scat (ECat cat _) = cat
ecatConstraints :: ECat -> [Constraint]
ecatConstraints (ECat _ cns) = cns
sameECat :: ECat -> ECat -> Bool
sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
coercionName :: Name
coercionName = Name Ident.identW [Unify [0]]
isCoercion :: Name -> Bool
isCoercion (Name fun [Unify [0]]) = Ident.isWildIdent fun
isCoercion _ = False
----------------------------------------------------------------------
-- * nonerasing MCFG
type MGrammar = MCFGrammar MCat Name MLabel Token
type MRule = MCFRule MCat Name MLabel Token
data MCat = MCat ECat [ELabel] deriving (Eq, Ord, Show)
type MLabel = ELabel
mcat2ecat :: MCat -> ECat
mcat2ecat (MCat cat _) = cat
mcat2scat :: MCat -> SCat
mcat2scat = ecat2scat . mcat2ecat
----------------------------------------------------------------------
-- * fast nonerasing MCFG
---- moved to FTypes by AR 20/9/2007
----------------------------------------------------------------------
-- * CFG
type CGrammar = CFGrammar CCat Name Token
type CRule = CFRule CCat Name Token
data CCat = CCat ECat ELabel deriving (Eq, Ord, Show)
ccat2ecat :: CCat -> ECat
ccat2ecat (CCat cat _) = cat
ccat2scat :: CCat -> SCat
ccat2scat = ecat2scat . ccat2ecat
----------------------------------------------------------------------
-- * pretty-printing
instance Print ECat where
prt (ECat cat constrs) = prt cat ++ "{" ++
concat [ prt path ++ "=" ++ prt term ++ ";" |
(path, term) <- constrs ] ++ "}"
instance Print MCat where
prt (MCat cat labels) = prt cat ++ prt labels
instance Print CCat where
prt (CCat cat label) = prt cat ++ prt label
---- instance Print FCat where ---- FCat

37
src-3.0/GF/Data/Compos.hs
View File

@@ -1,37 +0,0 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
module GF.Data.Compos (Compos(..),composOp,composM,composM_,composFold) where
import Control.Applicative (Applicative(..), Const(..), WrappedMonad(..))
import Data.Monoid (Monoid(..))
class Compos t where
compos :: Applicative f => (forall a. t a -> f (t a)) -> t c -> f (t c)
composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c
composOp f = runIdentity . compos (Identity . f)
composFold :: (Monoid o, Compos t) => (forall a. t a -> o) -> t c -> o
composFold f = getConst . compos (Const . f)
composM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)
composM f = unwrapMonad . compos (WrapMonad . f)
composM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()
composM_ f = unwrapMonad_ . composFold (WrapMonad_ . f)
newtype Identity a = Identity { runIdentity :: a }
instance Functor Identity where
fmap f (Identity x) = Identity (f x)
instance Applicative Identity where
pure = Identity
Identity f <*> Identity x = Identity (f x)
newtype WrappedMonad_ m = WrapMonad_ { unwrapMonad_ :: m () }
instance Monad m => Monoid (WrappedMonad_ m) where
mempty = WrapMonad_ (return ())
WrapMonad_ x `mappend` WrapMonad_ y = WrapMonad_ (x >> y)

30
src-3.0/GF/Data/Glue.hs
View File

@@ -1,30 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Glue
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:02 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@
-----------------------------------------------------------------------------
module GF.Data.Glue (decomposeSimple) where
import GF.Data.Trie2
import GF.Data.Operations
import Data.List
decomposeSimple :: Trie Char a -> [Char] -> Err [[Char]]
decomposeSimple t s = do
let ss = map (decompose t) $ words s
if any null ss
then Bad "unknown word in input"
else return $ concat [intersperse "&+" ws | ws <- ss]
exTrie = tcompile (zip ws ws) where
ws = words "ett tv\229 tre tjugo trettio hundra tusen"

67
src-3.0/GF/Data/IncrementalDeduction.hs
View File

@@ -1,67 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/09 09:28:44 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- Implementation of /incremental/ deductive parsing,
-- i.e. parsing one word at the time.
-----------------------------------------------------------------------------
module GF.Data.IncrementalDeduction
(-- * Type definitions
IncrementalChart,
-- * Functions
chartLookup,
buildChart,
chartList, chartKeys
) where
import Data.Array
import GF.Data.SortedList
import GF.Data.Assoc
----------------------------------------------------------------------
-- main functions
chartLookup :: (Ord item, Ord key) =>
IncrementalChart item key
-> Int -> key -> SList item
buildChart :: (Ord item, Ord key) =>
(item -> key) -- ^ key lookup function
-> (Int -> item -> SList item) -- ^ all inference rules for position k, collected
-> (Int -> SList item) -- ^ all axioms for position k, collected
-> (Int, Int) -- ^ input bounds
-> IncrementalChart item key
chartList :: (Ord item, Ord key) =>
IncrementalChart item key -- ^ the final chart
-> (Int -> item -> edge) -- ^ function building an edge from
-- the position and the item
-> [edge]
chartKeys :: (Ord item, Ord key) => IncrementalChart item key -> Int -> [key]
type IncrementalChart item key = Array Int (Assoc key (SList item))
----------
chartLookup chart k key = (chart ! k) ? key
buildChart keyof rules axioms bounds = finalChartArray
where buildState k = limit (rules k) $ axioms k
finalChartList = map buildState [fst bounds .. snd bounds]
finalChartArray = listArray bounds $ map stateAssoc finalChartList
stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ]
chartList chart combine = [ combine k item |
(k, state) <- assocs chart,
item <- concatMap snd $ aAssocs state ]
chartKeys chart k = aElems (chart ! k)

61
src-3.0/GF/Data/Map.hs
View File

@@ -1,61 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Map
-- Maintainer : Markus Forsberg
-- Stability : Stable
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:04 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Data.Map (
Map,
empty,
isEmpty,
(!),
(!+),
(|->),
(|->+),
(<+>),
flatten
) where
import GF.Data.RedBlack
type Map key el = Tree key el
infixl 6 |->
infixl 6 |->+
infixl 5 !
infixl 5 !+
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

127
src-3.0/GF/Data/OrdMap2.hs
View File

@@ -1,127 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : OrdMap2
-- Maintainer : Peter Ljunglöf
-- Stability : Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:05 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- The class of finite maps, as described in
-- \"Pure Functional Parsing\", section 2.2.2
-- and an example implementation,
-- derived from appendix A.2
--
-- /OBSOLETE/! this is only used in module "ChartParser"
-----------------------------------------------------------------------------
module GF.Data.OrdMap2 (OrdMap(..), Map) where
import Data.List (intersperse)
--------------------------------------------------
-- the class of ordered finite maps
class OrdMap m where
emptyMap :: Ord s => m s a
(|->) :: Ord s => s -> a -> m s a
isEmptyMap :: Ord s => m s a -> Bool
(?) :: Ord s => m s a -> s -> Maybe a
lookupWith :: Ord s => a -> m s a -> s -> a
mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a
unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a
makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a
assocs :: Ord s => m s a -> [(s,a)]
ordMap :: Ord s => [(s,a)] -> m s a
mapMap :: Ord s => (a -> b) -> m s a -> m s b
lookupWith z m s = case m ? s of
Just a -> a
Nothing -> z
unionMapWith join = union
where union [] = emptyMap
union [xs] = xs
union xyss = mergeWith join (union xss) (union yss)
where (xss, yss) = split xyss
split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
split xs = (xs, [])
--------------------------------------------------
-- finite maps as ordered associaiton lists,
-- paired with binary search trees
data Map s a = Map [(s,a)] (TreeMap s a)
instance (Eq s, Eq a) => Eq (Map s a) where
Map xs _ == Map ys _ = xs == ys
instance (Show s, Show a) => Show (Map s a) where
show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}"
where show' (s,a) = show s ++ "|->" ++ show a
instance OrdMap Map where
emptyMap = Map [] (makeTree [])
s |-> a = Map [(s,a)] (makeTree [(s,a)])
isEmptyMap (Map ass _) = null ass
Map _ tree ? s = lookupTree s tree
mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss)
where xyss = merge xss yss
merge [] yss = yss
merge xss [] = xss
merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss')
= case compare s t of
LT -> x : merge xss' yss
GT -> y : merge xss yss'
EQ -> (s, join x' y') : merge xss' yss'
makeMapWith join [] = emptyMap
makeMapWith join [(s,a)] = s |-> a
makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss)
where (xss, yss) = split xyss
split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys)
split xs = (xs, [])
assocs (Map xss _) = xss
ordMap xss = Map xss (makeTree xss)
mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree)
--------------------------------------------------
-- binary search trees
-- for logarithmic lookup time
data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a)
makeTree ass = tree
where
(tree,[]) = sl2bst (length ass) ass
sl2bst 0 ass = (Nil, ass)
sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass)
sl2bst n ass = (Node ltree s a rtree, css)
where llen = (n-1) `div` 2
rlen = n - 1 - llen
(ltree, (s,a):bss) = sl2bst llen ass
(rtree, css) = sl2bst rlen bss
lookupTree s Nil = Nothing
lookupTree s (Node left s' a right)
= case compare s s' of
LT -> lookupTree s left
GT -> lookupTree s right
EQ -> Just a
mapTree f Nil = Nil
mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right)

120
src-3.0/GF/Data/OrdSet.hs
View File

@@ -1,120 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : OrdSet
-- Maintainer : Peter Ljunglöf
-- Stability : Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:06 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- The class of ordered sets, as described in
-- \"Pure Functional Parsing\", section 2.2.1,
-- and an example implementation
-- derived from appendix A.1
--
-- /OBSOLETE/! this is only used in module "ChartParser"
-----------------------------------------------------------------------------
module GF.Data.OrdSet (OrdSet(..), Set) where
import Data.List (intersperse)
--------------------------------------------------
-- the class of ordered sets
class OrdSet m where
emptySet :: Ord a => m a
unitSet :: Ord a => a -> m a
isEmpty :: Ord a => m a -> Bool
elemSet :: Ord a => a -> m a -> Bool
(<++>) :: Ord a => m a -> m a -> m a
(<\\>) :: Ord a => m a -> m a -> m a
plusMinus :: Ord a => m a -> m a -> (m a, m a)
union :: Ord a => [m a] -> m a
makeSet :: Ord a => [a] -> m a
elems :: Ord a => m a -> [a]
ordSet :: Ord a => [a] -> m a
limit :: Ord a => (a -> m a) -> m a -> m a
xs <++> ys = fst (plusMinus xs ys)
xs <\\> ys = snd (plusMinus xs ys)
plusMinus xs ys = (xs <++> ys, xs <\\> ys)
union [] = emptySet
union [xs] = xs
union xyss = union xss <++> union yss
where (xss, yss) = split xyss
split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
split xs = (xs, [])
makeSet xs = union (map unitSet xs)
limit more start = limit' (start, start)
where limit' (old, new)
| isEmpty new' = old
| otherwise = limit' (plusMinus new' old)
where new' = union (map more (elems new))
--------------------------------------------------
-- sets as ordered lists,
-- paired with a binary tree
data Set a = Set [a] (TreeSet a)
instance Eq a => Eq (Set a) where
Set xs _ == Set ys _ = xs == ys
instance Ord a => Ord (Set a) where
compare (Set xs _) (Set ys _) = compare xs ys
instance Show a => Show (Set a) where
show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}"
instance OrdSet Set where
emptySet = Set [] (makeTree [])
unitSet a = Set [a] (makeTree [a])
isEmpty (Set xs _) = null xs
elemSet a (Set _ xt) = elemTree a xt
plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms))
where (ps, ms) = plm xs ys
plm [] ys = (ys, [])
plm xs [] = (xs, xs)
plm xs@(x:xs') ys@(y:ys') = case compare x y of
LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms)
GT -> let (ps, ms) = plm xs ys' in (y:ps, ms)
EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms)
elems (Set xs _) = xs
ordSet xs = Set xs (makeTree xs)
--------------------------------------------------
-- binary search trees
-- for logarithmic lookup time
data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a)
makeTree xs = tree
where (tree,[]) = sl2bst (length xs) xs
sl2bst 0 xs = (Nil, xs)
sl2bst 1 (a:xs) = (Node Nil a Nil, xs)
sl2bst n xs = (Node ltree a rtree, zs)
where llen = (n-1) `div` 2
rlen = n - 1 - llen
(ltree, a:ys) = sl2bst llen xs
(rtree, zs) = sl2bst rlen ys
elemTree a Nil = False
elemTree a (Node ltree x rtree)
= case compare a x of
LT -> elemTree a ltree
GT -> elemTree a rtree
EQ -> True

196
src-3.0/GF/Data/Parsers.hs
View File

@@ -1,196 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Parsers
-- Maintainer : Aarne Ranta
-- Stability : Almost Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:06 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- some parser combinators a la Wadler and Hutton.
-- no longer used in many places in GF
-- (only used in module "EBNF")
-----------------------------------------------------------------------------
module GF.Data.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 GF.Data.Operations
import Data.Char
import Data.List
infixr 2 |||, +||
infixr 3 ***
infixr 5 .>.
infixr 5 ...
infixr 5 ....
infixr 5 +..
infixr 5 ..+
infixr 6 |>
infixr 3 <<<
type Parser a b = [a] -> [(b,[a])]
parseResults :: Parser a b -> [a] -> [b]
parseResults p s = [x | (x,r) <- p s, null r]
parseResultErr :: Show a => Parser a b -> [a] -> Err b
parseResultErr p s = case parseResults p s of
[x] -> return x
[] -> case
maximumBy (\x y -> compare (length y) (length x)) (s:[r | (_,r) <- p s]) of
r -> Bad $ "\nno parse; reached" ++++ take 300 (show r)
_ -> Bad "ambiguous"
(...) :: Parser a b -> Parser a c -> Parser a (b,c)
(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t]
(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c
(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t]
(|||) :: Parser a b -> Parser a b -> Parser a b
(p ||| q) s = p s ++ q s
(+||) :: Parser a b -> Parser a b -> Parser a b
p1 +|| p2 = take 1 . (p1 ||| p2)
literal :: (Eq a) => a -> Parser a a
literal x (c:cs) = [(x,cs) | x == c]
literal _ _ = []
(***) :: Parser a b -> (b -> c) -> Parser a c
(p *** f) s = [(f x,r) | (x,r) <- p s]
succeed :: b -> Parser a b
succeed v s = [(v,s)]
fails :: Parser a b
fails s = []
(+..) :: Parser a b -> Parser a c -> Parser a c
p1 +.. p2 = p1 ... p2 *** snd
(..+) :: Parser a b -> Parser a c -> Parser a b
p1 ..+ p2 = p1 ... p2 *** fst
(<<<) :: Parser a b -> c -> Parser a c -- return
p <<< v = p *** (\x -> v)
(|>) :: Parser a b -> (b -> Bool) -> Parser a b
p |> b = p .>. (\x -> if b x then succeed x else fails)
many :: Parser a b -> Parser a [b]
many p = (p ... many p *** uncurry (:)) +|| succeed []
some :: Parser a b -> Parser a [b]
some p = (p ... many p) *** uncurry (:)
longestOfMany :: Parser a b -> Parser a [b]
longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed []
closure :: (b -> Parser a b) -> (b -> Parser a b)
closure p v = p v .>. closure p ||| succeed v
pJunk :: Parser Char String
pJunk = longestOfMany (satisfy (\x -> elem x "\n\t "))
pJ :: Parser Char a -> Parser Char a
pJ p = pJunk +.. p ..+ pJunk
pTList :: String -> Parser Char a -> Parser Char [a]
pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999
pTJList :: String -> String -> Parser Char a -> Parser Char [a]
pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:))
pElem :: [String] -> Parser Char String
pElem l = foldr (+||) fails (map literals l)
(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c)
p1 .... p2 = p1 ... pJunk +.. p2
item :: Parser a a
item (c:cs) = [(c,cs)]
item [] = []
satisfy :: (a -> Bool) -> Parser a a
satisfy b = item |> b
literals :: (Eq a,Show a) => [a] -> Parser a [a]
literals l = case l of
[] -> succeed []
a:l -> literal a ... literals l *** (\ (x,y) -> x:y)
lits :: (Eq a,Show a) => [a] -> Parser a [a]
lits ts = literals ts
jL :: String -> Parser Char String
jL = pJ . lits
pParenth :: Parser Char a -> Parser Char a
pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')'
-- | p,...,p
pCommaList :: Parser Char a -> Parser Char [a]
pCommaList p = pTList "," (pJ p)
-- | the same or nothing
pOptCommaList :: Parser Char a -> Parser Char [a]
pOptCommaList p = pCommaList p ||| succeed []
-- | (p,...,p), poss. empty
pArgList :: Parser Char a -> Parser Char [a]
pArgList p = pParenth (pCommaList p) ||| succeed []
-- | min. 2 args
pArgList2 :: Parser Char a -> Parser Char [a]
pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:)
longestOfSome :: Parser a b -> Parser a [b]
longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y)
pIdent :: Parser Char String
pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:)
where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\''
pLetter, pDigit :: Parser Char Char
pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++
['\192' .. '\255'])) -- no such in Char
pDigit = satisfy isDigit
pLetters :: Parser Char String
pLetters = longestOfSome pLetter
pAlphanum, pAlphaPlusChar :: Parser Char Char
pAlphanum = pDigit ||| pLetter
pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'")
pQuotedString :: Parser Char String
pQuotedString = literal '"' +.. pEndQuoted where
pEndQuoted =
literal '"' *** (const [])
+|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:))
+|| item .>. \ c -> pEndQuoted *** (c:)
pIntc :: Parser Char Int
pIntc = some (satisfy numb) *** read
where numb x = elem x ['0'..'9']

64
src-3.0/GF/Data/RedBlack.hs
View File

@@ -1,64 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : RedBlack
-- Maintainer : Markus Forsberg
-- Stability : Stable
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- Modified version of Osanaki's implementation.
-----------------------------------------------------------------------------
module GF.Data.RedBlack (
emptyTree,
isEmpty,
Tree,
lookupTree,
insertTree,
flatten
) where
data Color = R | B
deriving (Show,Read)
data Tree key el = E | T Color (Tree key el) (key,el) (Tree key el)
deriving (Show,Read)
balance :: Color -> Tree a b -> (a,b) -> Tree a b -> Tree a b
balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
balance color a x b = T color a x b
emptyTree :: Tree key el
emptyTree = E
isEmpty :: Tree key el -> Bool
isEmpty (E) = True
isEmpty _ = False
lookupTree :: Ord a => a -> Tree a b -> Maybe b
lookupTree _ E = Nothing
lookupTree x (T _ a (y,z) b)
| x < y = lookupTree x a
| x > y = lookupTree x b
| otherwise = return z
insertTree :: Ord a => (a,b) -> Tree a b -> Tree a b
insertTree (key,el) tree = T B a y b
where
T _ a y b = ins tree
ins E = T R E (key,el) E
ins (T color a y@(key',el') b)
| key < key' = balance color (ins a) y b
| key > key' = balance color a y (ins b)
| otherwise = T color a (key',el) b
flatten :: Tree a b -> [(a,b)]
flatten E = []
flatten (T _ left (key,e) right)
= (flatten left) ++ ((key,e):(flatten right))

19
src-3.0/GF/Data/SharedString.hs
View File

@@ -1,19 +0,0 @@
module GF.Data.SharedString (shareString) where
import Data.HashTable as H
import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE stringPool #-}
stringPool :: HashTable String String
stringPool = unsafePerformIO $ new (==) hashString
{-# NOINLINE shareString #-}
shareString :: String -> String
shareString s = unsafePerformIO $ do
mv <- H.lookup stringPool s
case mv of
Just s' -> return s'
Nothing -> do
H.insert stringPool s s
return s

129
src-3.0/GF/Data/Trie.hs
View File

@@ -1,129 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Trie
-- Maintainer : Markus Forsberg
-- Stability : Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:09 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Data.Trie (
tcompile,
collapse,
Trie,
trieLookup,
decompose,
Attr,
atW, atP, atWP
) where
import GF.Data.Map
--- data Attr = W | P | WP deriving Eq
type Attr = Int
atW, atP, atWP :: Attr
(atW,atP,atWP) = (0,1,2)
newtype TrieT = TrieT ([(Char,TrieT)],[(Attr,String)])
newtype Trie = Trie (Map Char Trie, [(Attr,String)])
emptyTrie = TrieT ([],[])
optimize :: TrieT -> Trie
optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty,
res)
collapse :: Trie -> [(String,[(Attr,String)])]
collapse trie = collapse' trie []
where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))]
else (reverse s,(x:xs)):
concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
collapse' (Trie (map,[])) s
= concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
tcompile :: [(String,[(Attr,String)])] -> Trie
tcompile xs = optimize $ build xs emptyTrie
build :: [(String,[(Attr,String)])] -> TrieT -> TrieT
build [] trie = trie
build (x:xs) trie = build xs (insert x trie)
where
insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res)
insert ((s:ss),ys) (TrieT (xs,res))
= case (span (\(s',_) -> s' /= s) xs) of
(xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrie)):xs),res)
(xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res)
trieLookup :: Trie -> String -> (String,[(Attr,String)])
trieLookup trie s = apply trie s s
apply :: Trie -> String -> String -> (String,[(Attr,String)])
apply (Trie (_,res)) [] inp = (inp,res)
apply (Trie (map,_)) (s:ss) inp
= case map ! s of
Just trie -> apply trie ss inp
Nothing -> (inp,[])
-- Composite analysis (Huet's unglue algorithm)
-- only legaldecompositions are accepted.
-- With legal means that the composite forms are ordered correctly
-- with respect to the attributes W,P and WP.
-- Composite analysis
testTrie = tcompile [("flick",[(atP,"P")]),("knopp",[(atW,"W")]),("flaggstångs",[(atWP,"WP")])]
decompose :: Trie -> String -> [String]
decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie
-- The function legal checks if the decomposition is in fact a possible one.
legal :: Trie -> [String] -> [String]
legal _ [] = []
legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else []
where
test [] = False
test [xs] = elem atW xs || elem atWP xs
test (xs:xss) = (elem atP xs || elem atWP xs) && test xss
react :: String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String]
react input output back occ (Trie (arcs,res)) init =
case res of -- Accept = non-empty res.
[] -> continue back
_ -> let pushout = (occ:output)
in case input of
[] -> reverse $ map reverse pushout
_ -> let pushback = ((input,pushout):back)
in continue pushback
where continue cont = case input of
[] -> backtrack cont init
(l:rest) -> case arcs ! l of
Just trie ->
react rest output cont (l:occ) trie init
Nothing -> backtrack cont init
backtrack :: [(String,[String])] -> Trie -> [String]
backtrack [] _ = []
backtrack ((input,output):back) trie
= react input output back [] trie trie
{-
-- The function legal checks if the decomposition is in fact a possible one.
legal :: Trie -> [String] -> [String]
legal _ [] = []
legal trie input
| test $
map ((map fst).snd.(trieLookup trie)) input = input
| otherwise = []
where -- test checks that the Attrs are in the correct order.
test [] = False -- This case should never happen.
test [xs] = elem W xs || elem WP xs
test (xs:xss) = (elem P xs || elem WP xs) && test xss
-}

120
src-3.0/GF/Data/Trie2.hs
View File

@@ -1,120 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Trie2
-- Maintainer : Markus Forsberg
-- Stability : Stable
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:10 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Data.Trie2 (
tcompile,
collapse,
Trie,
trieLookup,
decompose,
--- Attr, atW, atP, atWP,
emptyTrie
) where
import GF.Data.Map
import Data.List
newtype TrieT a b = TrieT ([(a,TrieT a b)],[b])
newtype Trie a b = Trie (Map a (Trie a b), [b])
emptyTrieT = TrieT ([],[])
emptyTrie :: Trie a b
emptyTrie = Trie (empty,[])
optimize :: (Ord a,Eq b) => TrieT a b -> Trie a b
optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty,
nub res) --- nub by AR
collapse :: Ord a => Trie a b -> [([a],[b])]
collapse trie = collapse' trie []
where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))]
else (reverse s,(x:xs)):
concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
collapse' (Trie (map,[])) s
= concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
tcompile :: (Ord a,Eq b) => [([a],[b])] -> Trie a b
tcompile xs = optimize $ build xs emptyTrieT
build :: Ord a => [([a],[b])] -> TrieT a b -> TrieT a b
build [] trie = trie
build (x:xs) trie = build xs (insert x trie)
where
insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res)
insert ((s:ss),ys) (TrieT (xs,res))
= case (span (\(s',_) -> s' /= s) xs) of
(xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrieT)):xs),res)
(xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res)
trieLookup :: Ord a => Trie a b -> [a] -> ([a],[b])
trieLookup trie s = apply trie s s
apply :: Ord a => Trie a b -> [a] -> [a] -> ([a],[b])
apply (Trie (_,res)) [] inp = (inp,res)
apply (Trie (map,_)) (s:ss) inp
= case map ! s of
Just trie -> apply trie ss inp
Nothing -> (inp,[])
-----------------------------
-- from Trie for strings; simplified for GF by making binding always possible (AR)
decompose :: Ord a => Trie a b -> [a] -> [[a]]
decompose trie sentence = backtrack [(sentence,[])] trie
react :: Ord a => [a] -> [[a]] -> [([a],[[a]])] ->
[a] -> Trie a b -> Trie a b -> [[a]]
-- String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String]
react input output back occ (Trie (arcs,res)) init =
case res of -- Accept = non-empty res.
[] -> continue back
_ -> let pushout = (occ:output)
in case input of
[] -> reverse $ map reverse pushout
_ -> let pushback = ((input,pushout):back)
in continue pushback
where continue cont = case input of
[] -> backtrack cont init
(l:rest) -> case arcs ! l of
Just trie ->
react rest output cont (l:occ) trie init
Nothing -> backtrack cont init
backtrack :: Ord a => [([a],[[a]])] -> Trie a b -> [[a]]
backtrack [] _ = []
backtrack ((input,output):back) trie
= react input output back [] trie trie
{- so this is not needed from the original
type Attr = Int
atW, atP, atWP :: Attr
(atW,atP,atWP) = (0,1,2)
decompose :: Ord a => Trie a (Int,b) -> [a] -> [[a]]
decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie
-- The function legal checks if the decomposition is in fact a possible one.
legal :: Ord a => Trie a (Int,b) -> [[a]] -> [[a]]
legal _ [] = []
legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else []
where
test [] = False
test [xs] = elem atW xs || elem atWP xs
test (xs:xss) = (elem atP xs || elem atWP xs) && test xss
-}

57
src-3.0/GF/Data/XML.hs
View File

@@ -1,57 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : XML
-- Maintainer : BB
-- Stability : (stable)
-- Portability : (portable)
--
-- Utilities for creating XML documents.
-----------------------------------------------------------------------------
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
import GF.Data.Utilities
data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
deriving (Ord,Eq,Show)
type Attr = (String,String)
comments :: [String] -> [XML]
comments = map Comment
showXMLDoc :: XML -> String
showXMLDoc xml = showsXMLDoc xml ""
showsXMLDoc :: XML -> ShowS
showsXMLDoc xml = showString header . showsXML xml
where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
showsXML :: XML -> ShowS
showsXML (Data s) = showString s
showsXML (CData s) = showString "<![CDATA[" . showString s .showString "]]>"
showsXML (ETag t as) = showChar '<' . showString t . showsAttrs as . showString "/>"
showsXML (Tag t as cs) =
showChar '<' . showString t . showsAttrs as . showChar '>'
. concatS (map showsXML cs) . showString "</" . showString t . showChar '>'
showsXML (Comment c) = showString "<!-- " . showString c . showString " -->"
showsXML (Empty) = id
showsAttrs :: [Attr] -> ShowS
showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
showsAttr :: Attr -> ShowS
showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
escape :: String -> String
escape = concatMap escChar
where
escChar '<' = "&lt;"
escChar '>' = "&gt;"
escChar '&' = "&amp;"
escChar '"' = "&quot;"
escChar c = [c]
bottomUpXML :: (XML -> XML) -> XML -> XML
bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
bottomUpXML f x = f x

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

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

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

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

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

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

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

@@ -1,274 +0,0 @@
module GF.Devel.Compile.AbsGF where
-- Haskell module generated by the BNF converter
newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show)
newtype LString = LString String deriving (Eq,Ord,Show)
data Grammar =
Gr [ModDef]
deriving (Eq,Ord,Show)
data ModDef =
MModule ComplMod ModType ModBody
deriving (Eq,Ord,Show)
data ModType =
MAbstract PIdent
| MResource PIdent
| MGrammar PIdent
| MInterface PIdent
| MConcrete PIdent PIdent
| MInstance PIdent PIdent
deriving (Eq,Ord,Show)
data ModBody =
MBody Extend Opens [TopDef]
| MNoBody [Included]
| MWith Included [Open]
| MWithBody Included [Open] Opens [TopDef]
| MWithE [Included] Included [Open]
| MWithEBody [Included] Included [Open] Opens [TopDef]
| MReuse PIdent
| MUnion [Included]
deriving (Eq,Ord,Show)
data Extend =
Ext [Included]
| NoExt
deriving (Eq,Ord,Show)
data Opens =
NoOpens
| OpenIn [Open]
deriving (Eq,Ord,Show)
data Open =
OName PIdent
| OQual PIdent PIdent
deriving (Eq,Ord,Show)
data ComplMod =
CMCompl
| CMIncompl
deriving (Eq,Ord,Show)
data Included =
IAll PIdent
| ISome PIdent [PIdent]
| IMinus PIdent [PIdent]
deriving (Eq,Ord,Show)
data TopDef =
DefCat [CatDef]
| DefFun [FunDef]
| DefFunData [FunDef]
| DefDef [Def]
| DefData [DataDef]
| DefPar [ParDef]
| DefOper [Def]
| DefLincat [Def]
| DefLindef [Def]
| DefLin [Def]
| DefPrintCat [Def]
| DefPrintFun [Def]
| DefFlag [Def]
| DefPrintOld [Def]
| DefLintype [Def]
| DefPattern [Def]
| DefPackage PIdent [TopDef]
| DefVars [Def]
| DefTokenizer PIdent
deriving (Eq,Ord,Show)
data Def =
DDecl [Name] Exp
| DDef [Name] Exp
| DPatt Name [Patt] Exp
| DFull [Name] Exp Exp
deriving (Eq,Ord,Show)
data FunDef =
FDecl [Name] Exp
deriving (Eq,Ord,Show)
data CatDef =
SimpleCatDef PIdent [DDecl]
| ListCatDef PIdent [DDecl]
| ListSizeCatDef PIdent [DDecl] Integer
deriving (Eq,Ord,Show)
data DataDef =
DataDef Name [DataConstr]
deriving (Eq,Ord,Show)
data DataConstr =
DataId PIdent
| DataQId PIdent PIdent
deriving (Eq,Ord,Show)
data ParDef =
ParDefDir PIdent [ParConstr]
| ParDefAbs PIdent
deriving (Eq,Ord,Show)
data ParConstr =
ParConstr PIdent [DDecl]
deriving (Eq,Ord,Show)
data Name =
PIdentName PIdent
| ListName PIdent
deriving (Eq,Ord,Show)
data LocDef =
LDDecl [PIdent] Exp
| LDDef [PIdent] Exp
| LDFull [PIdent] Exp Exp
deriving (Eq,Ord,Show)
data Exp =
EPIdent PIdent
| EConstr PIdent
| ECons PIdent
| ESort Sort
| EString String
| EInt Integer
| EFloat Double
| EMeta
| EEmpty
| EData
| EList PIdent Exps
| EStrings String
| ERecord [LocDef]
| ETuple [TupleComp]
| EIndir PIdent
| ETyped Exp Exp
| EProj Exp Label
| EQConstr PIdent PIdent
| EQCons PIdent PIdent
| EApp Exp Exp
| ETable [Case]
| ETTable Exp [Case]
| EVTable Exp [Exp]
| ECase Exp [Case]
| EVariants [Exp]
| EPre Exp [Altern]
| EStrs [Exp]
| EPatt Patt
| EPattType Exp
| ESelect Exp Exp
| ETupTyp Exp Exp
| EExtend Exp Exp
| EGlue Exp Exp
| EConcat Exp Exp
| EAbstr [Bind] Exp
| ECTable [Bind] Exp
| EProd Decl Exp
| ETType Exp Exp
| ELet [LocDef] Exp
| ELetb [LocDef] Exp
| EWhere Exp [LocDef]
| EEqs [Equation]
| EExample Exp String
| ELString LString
| ELin PIdent
deriving (Eq,Ord,Show)
data Exps =
NilExp
| ConsExp Exp Exps
deriving (Eq,Ord,Show)
data Patt =
PChar
| PChars String
| PMacro PIdent
| PM PIdent PIdent
| PW
| PV PIdent
| PCon PIdent
| PQ PIdent PIdent
| PInt Integer
| PFloat Double
| PStr String
| PR [PattAss]
| PTup [PattTupleComp]
| PC PIdent [Patt]
| PQC PIdent PIdent [Patt]
| PDisj Patt Patt
| PSeq Patt Patt
| PRep Patt
| PAs PIdent Patt
| PNeg Patt
deriving (Eq,Ord,Show)
data PattAss =
PA [PIdent] Patt
deriving (Eq,Ord,Show)
data Label =
LPIdent PIdent
| LVar Integer
deriving (Eq,Ord,Show)
data Sort =
Sort_Type
| Sort_PType
| Sort_Tok
| Sort_Str
| Sort_Strs
deriving (Eq,Ord,Show)
data Bind =
BPIdent PIdent
| BWild
deriving (Eq,Ord,Show)
data Decl =
DDec [Bind] Exp
| DExp Exp
deriving (Eq,Ord,Show)
data TupleComp =
TComp Exp
deriving (Eq,Ord,Show)
data PattTupleComp =
PTComp Patt
deriving (Eq,Ord,Show)
data Case =
Case Patt Exp
deriving (Eq,Ord,Show)
data Equation =
Equ [Patt] Exp
deriving (Eq,Ord,Show)
data Altern =
Alt Exp Exp
deriving (Eq,Ord,Show)
data DDecl =
DDDec [Bind] Exp
| DDExp Exp
deriving (Eq,Ord,Show)
data OldGrammar =
OldGr Include [TopDef]
deriving (Eq,Ord,Show)
data Include =
NoIncl
| Incl [FileName]
deriving (Eq,Ord,Show)
data FileName =
FString String
| FPIdent PIdent
| FSlash FileName
| FDot FileName
| FMinus FileName
| FAddId PIdent FileName
deriving (Eq,Ord,Show)

1089
src-3.0/GF/Devel/Compile/CheckGrammar.hs
View File

File diff suppressed because it is too large Load Diff

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

@@ -1,205 +0,0 @@
module GF.Devel.Compile.Compile (batchCompile) where
-- the main compiler passes
import GF.Devel.Compile.GetGrammar
import GF.Devel.Compile.Extend
import GF.Devel.Compile.Rename
import GF.Devel.Compile.CheckGrammar
import GF.Devel.Compile.Refresh
import GF.Devel.Compile.Optimize
import GF.Devel.Compile.Factorize
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Infra.Ident
import GF.Devel.Grammar.PrGF
----import GF.Devel.Grammar.Lookup
import GF.Devel.Infra.ReadFiles
import GF.Infra.Option ----
import GF.Data.Operations
import GF.Devel.UseIO
import GF.Devel.Arch
import Control.Monad
import System.Directory
batchCompile :: Options -> [FilePath] -> IO GF
batchCompile opts files = do
let defOpts = addOptions opts (options [emitCode])
egr <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files
case egr of
Ok (_,gr) -> return gr
Bad s -> error s
-- to output an intermediate stage
intermOut :: Options -> Option -> String -> IOE ()
intermOut opts opt s =
if oElem opt opts || oElem (iOpt "show_all") opts
then
ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s)
else
return ()
prMod :: SourceModule -> String
prMod = prModule
-- | the environment
type CompileEnv = (Int,GF)
-- | compile with one module as starting point
-- command-line options override options (marked by --#) in the file
-- As for path: if it is read from file, the file path is prepended to each name.
-- If from command line, it is used as it is.
compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv
compileModule opts1 env file = do
opts0 <- ioeIO $ getOptionsFromFile file
let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
let opts = addOptions opts1 opts0
let fpath = dropFileName file
ps0 <- ioeIO $ pathListOpts opts fpath
let ps1 = if (useFileOpt && not useLineOpt)
then (ps0 ++ map (combine fpath) ps0)
else ps0
ps <- ioeIO $ extendPathEnv ps1
let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
let sgr = snd env
let rfs = [] ---- files already in memory and their read times
let file' = if useFileOpt then takeFileName file else file -- find file itself
files <- getAllFiles opts ps rfs file'
ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
let names = map justModuleName files
ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
let sgr2 = sgr ----MGrammar [m | m@(i,_) <- modules sgr,
---- notElem (prt i) $ map dropExtension names]
let env0 = (0,sgr2)
(e,mm) <- foldIOE (compileOne opts) env0 files
maybe (return ()) putStrLnE mm
return e
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne opts env@(_,srcgr) file = do
let putp s = putPointE opts ("\n" ++ s)
let putpp = putPointEsil opts
let putpOpt v m act
| oElem beVerbose opts = putp v act
| oElem beSilent opts = putpp v act
| otherwise = ioeIO (putStrFlush ("\n" ++ m)) >> act
let gf = takeExtensions file
let path = dropFileName file
let name = dropExtension file
let mos = gfmodules srcgr
case gf of
-- for compiled gf, read the file and update environment
-- also undo common subexp optimization, to enable normal computations
".gfn" -> do
sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file
let sm1 = unsubexpModule sm0
sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule srcgr sm1
extendCompileEnv env sm
-- for gf source, do full compilation and generate code
_ -> do
let modu = dropExtension file
b1 <- ioeIO $ doesFileExist file
if not b1
then compileOne opts env $ gfoFile $ modu
else do
sm0 <-
putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file
(k',sm) <- compileSourceModule opts env sm0
let sm1 = sm ----
---- if isConcr sm then shareModule sm else sm -- cannot expand Str
if oElem (iOpt "doemit") opts
then putpp " generating code... " $ generateModuleCode opts path sm1
else return ()
---- -- sm is optimized before generation, but not in the env
---- let cm2 = unsubexpModule cm
extendCompileEnvInt env (k',sm) ---- sm1
where
isConcr (_,mi) = case mi of
---- ModMod m -> isModCnc m && mstatus m /= MSIncomplete
_ -> False
compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr) mo@(i,mi) = do
intermOut opts (iOpt "show_gf") (prMod mo)
let putp = putPointE opts
putpp = putPointEsil opts
stopIf n comp m =
if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return m else comp m
stopIfV v n comp m =
if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return (m,v) else comp m
moe <- stopIf 1 (putpp " extending" . ioeErr . extendModule gr) mo
intermOut opts (iOpt "show_extend") (prMod moe)
mor <- stopIf 2 (putpp " renaming" . ioeErr . renameModule gr) moe
intermOut opts (iOpt "show_rename") (prMod mor)
(moc,warnings) <-
stopIfV [] 3 (putpp " type checking" . ioeErr . showCheckModule gr) mor
if null warnings then return () else putp warnings $ return ()
intermOut opts (iOpt "show_typecheck") (prMod moc)
(mox,k') <- stopIfV k 4 (putpp " refreshing " . ioeErr . refreshModule k) moc
intermOut opts (iOpt "show_refresh") (prMod mox)
moo <- stopIf 5 (putpp " optimizing " . ioeErr . optimizeModule opts gr) mox
intermOut opts (iOpt "show_optimize") (prMod moo)
mof <- stopIf 6 (putpp " factorizing " . ioeErr . optimizeModule opts gr) moo
intermOut opts (iOpt "show_factorize") (prMod mof)
return (k',moo) ----
generateModuleCode :: Options -> InitPath -> SourceModule -> IOE ()
generateModuleCode opts path minfo@(name,info) = do
let pname = combine path (prt name)
let minfo0 = minfo
let minfo1 = subexpModule minfo0
let minfo2 = minfo1
let (file,out) = (gfoFile pname, prGF (gfModules [minfo2]))
putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ out
return () ----- minfo2
where
putp = putPointE opts
putpp = putPointEsil opts
-- auxiliaries
pathListOpts :: Options -> FileName -> IO [InitPath]
pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
----reverseModules (MGrammar ms) = MGrammar $ reverse ms
emptyCompileEnv :: CompileEnv
emptyCompileEnv = (0,emptyGF)
extendCompileEnvInt (_,gf) (k,(s,m)) = return (k, addModule s m gf)
extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm)

26
src-3.0/GF/Devel/Compile/ErrM.hs
View File

@@ -1,26 +0,0 @@
-- BNF Converter: Error Monad
-- Copyright (C) 2004 Author: Aarne Ranta
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
module GF.Devel.Compile.ErrM where
-- the Error monad: like Maybe type with error msgs
import Control.Monad (MonadPlus(..), liftM)
data Err a = Ok a | Bad String
deriving (Read, Show, Eq, Ord)
instance Monad Err where
return = Ok
fail = Bad
Ok a >>= f = f a
Bad s >>= f = Bad s
instance Functor Err where
fmap = liftM
instance MonadPlus Err where
mzero = Bad "Err.mzero"
mplus (Bad _) y = y
mplus x _ = x

154
src-3.0/GF/Devel/Compile/Extend.hs
View File

@@ -1,154 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Extend
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.18 $
--
-- AR 14\/5\/2003 -- 11\/11
-- 4/12/2007 this module is still very very messy... ----
--
-- The top-level function 'extendModule'
-- extends a module symbol table by indirections to the module it extends
-----------------------------------------------------------------------------
module GF.Devel.Compile.Extend (
extendModule
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.Lookup
import GF.Devel.Grammar.Macros
import GF.Infra.Ident
import GF.Data.Operations
import Data.List (nub)
import Data.Map
import Control.Monad
extendModule :: GF -> SourceModule -> Err SourceModule
extendModule gf nmo0 = do
(name,mo) <- rebuildModule gf nmo0
case mtype mo of
---- Just to allow inheritance in incomplete concrete (which are not
---- compiled anyway), extensions are not built for them.
---- Should be replaced by real control. AR 4/2/2005
MTConcrete _ | not (isCompleteModule mo) -> return (name,mo)
_ -> do
mo' <- foldM (extOne name) mo (mextends mo)
return (name, mo')
where
extOne name mo (n,cond) = do
mo0 <- lookupModule gf n
-- test that the module types match
testErr True ---- (legalExtension mo mo0)
("illegal extension type to module" +++ prt name)
-- find out if the old is complete
let isCompl = isCompleteModule mo0
-- if incomplete, remove it from extension list --- because??
let me' = (if isCompl then id else (Prelude.filter ((/=n) . fst)))
(mextends mo)
-- build extension depending on whether the old module is complete
js0 <- extendMod isCompl n (isInherited cond) name (mjments mo0) (mjments mo)
return $ mo {mextends = me', mjments = js0}
-- | When extending a complete module: new information is inserted,
-- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied.
extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident ->
Map Ident Judgement -> Map Ident Judgement ->
Err (Map Ident Judgement)
extendMod isCompl name cond base old new = foldM try new $ assocs old where
try t i@(c,_) | not (cond c) = return t
try t i@(c,_) = errIn ("constant" +++ prt c) $
tryInsert (extendAnyInfo isCompl name base) indirIf t i
indirIf = if isCompl then indirInfo name else id
indirInfo :: Ident -> Judgement -> Judgement
indirInfo n ju = case jform ju of
JLink -> ju -- original link is passed
_ -> linkInherited (isConstructor ju) n
extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement
extendAnyInfo isc n o i j =
errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $
unifyJudgement i j
tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
Map a b -> (a,b) -> Err (Map a b)
tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of
Just info0 -> do
info1 <- unif info info0
return $ insert x info1 tree
_ -> return $ insert x (indir info) tree
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: GF -> SourceModule -> Err SourceModule
rebuildModule gr mo@(i,mi) = case mtype mi of
-- copy interface contents to instance
MTInstance i0 -> do
m0 <- lookupModule gr i0
testErr (isInterface m0) ("not an interface:" +++ prt i0)
js1 <- extendMod False i0 (const True) i (mjments m0) (mjments mi)
--- to avoid double inclusions, in instance J of I0 = J0 ** ...
case mextends mi of
[] -> return $ (i,mi {mjments = js1})
es -> do
mes <- mapM (lookupModule gr . fst) es ---- restricted?? 12/2007
let notInExts c _ = all (notMember c . mjments) mes
let js2 = filterWithKey notInExts js1
return $ (i,mi {
mjments = js2
})
-- copy functor contents to instantiation, and also add opens
_ -> case minstances mi of
[((ext,incl),ops)] -> do
let interfs = Prelude.map fst ops
-- test that all interfaces are instantiated
let isCompl = Prelude.null [i | (_,i) <- minterfaces mi, notElem i interfs]
testErr isCompl ("module" +++ prt i +++ "remains incomplete")
-- look up the functor and build new opens set
mi0 <- lookupModule gr ext
let
ops1 = nub $
mopens mi -- own opens; N.B. mi0 has been name-resolved already
++ ops -- instantiating opens
++ [(n,o) |
(n,o) <- mopens mi0, notElem o interfs] -- ftor's non-if opens
++ [(i,i) | i <- Prelude.map snd ops] ---- -- insts w. real names
-- combine flags; new flags have priority
let fs1 = union (mflags mi) (mflags mi0)
-- copy inherited functor judgements
let js0 = [ci | ci@(c,_) <- assocs (mjments mi0), isInherited incl c]
let js1 = fromList (assocs (mjments mi) ++ js0)
return $ (i,mi {
mflags = fs1,
mextends = mextends mi, -- extends of instantiation
mopens = ops1,
mjments = js1
})
_ -> return (i,mi)

251
src-3.0/GF/Devel/Compile/Factorize.hs
View File

@@ -1,251 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : OptimizeGF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:33 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- Optimizations on GF source code: sharing, parametrization, value sets.
--
-- optimization: sharing branches in tables. AR 25\/4\/2003.
-- following advice of Josef Svenningsson
-----------------------------------------------------------------------------
module GF.Devel.Compile.Factorize (
optModule,
unshareModule,
unsubexpModule,
unoptModule,
subexpModule,
shareModule
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.PrGF (prt)
import qualified GF.Devel.Grammar.Macros as C
import GF.Devel.Grammar.Lookup
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List
optModule :: SourceModule -> SourceModule
optModule = subexpModule . shareModule
shareModule = processModule optim
unoptModule :: GF -> SourceModule -> SourceModule
unoptModule gr = unshareModule gr . unsubexpModule
unshareModule :: GF -> SourceModule -> SourceModule
unshareModule gr = processModule (const (unoptim gr))
processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule
processModule opt (i,mo) =
(i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)})
shareInfo :: (Term -> Term) -> Judgement -> Judgement
shareInfo opt ju = ju {jdef = opt (jdef ju)}
-- the function putting together optimizations
optim :: Ident -> Term -> Term
optim c = values . factor c 0
-- we need no counter to create new variable names, since variables are
-- local to tables ----
-- factor parametric branches
factor :: Ident -> Int -> Term -> Term
factor c i t = case t of
T _ [_] -> t
T _ [] -> t
T (TComp ty) cs ->
T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
_ -> C.composSafeOp (factor c i) t
where
factors i psvs = -- we know psvs has at least 2 elements
let p = qqIdent c i
vs' = map (mkFun p) psvs
in if allEqs vs'
then mkCase p vs'
else psvs
mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
allEqs (v:vs) = all (==v) vs
mkCase p (v:_) = [(PV p, v)]
--- we hope this will be fresh and don't check...
qqIdent c i = identC ("_q_" ++ prt c ++ "__" ++ show i)
-- we need to replace subterms
replace :: Term -> Term -> Term -> Term
replace old new trm = case trm of
-- these are the important cases, since they can correspond to patterns
QC _ _ | trm == old -> new
App t ts | trm == old -> new
App t ts -> App (repl t) (repl ts)
R _ | isRec && trm == old -> new
_ -> C.composSafeOp repl trm
where
repl = replace old new
isRec = case trm of
R _ -> True
_ -> False
-- It is very important that this is performed only after case
-- expansion since otherwise the order and number of values can
-- be incorrect. Guaranteed by the TComp flag.
values :: Term -> Term
values t = case t of
T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization
T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
T (TTyped ty) cs -> V ty [values t | (_, t) <- cs]
---- why are these left?
---- printing with GrammarToSource does not preserve the distinction
_ -> C.composSafeOp values t
-- to undo the effect of factorization
unoptim :: GF -> Term -> Term
unoptim gr = unfactor gr
unfactor :: GF -> Term -> Term
unfactor gr t = case t of
T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
_ -> C.composSafeOp unfac t
where
unfac = unfactor gr
vals = err error id . allParamValues gr
restore x u t = case t of
Vr y | y == x -> u
_ -> C.composSafeOp (restore x u) t
----------------------------------------------------------------------
{-
This module implements a simple common subexpression elimination
for gfc grammars, to factor out shared subterms in lin rules.
It works in three phases:
(1) collectSubterms collects recursively all subterms of forms table and (P x..y)
from lin definitions (experience shows that only these forms
tend to get shared) and counts how many times they occur
(2) addSubexpConsts takes those subterms t that occur more than once
and creates definitions of form "oper A''n = t" where n is a
fresh number; notice that we assume no ids of this form are in
scope otherwise
(3) elimSubtermsMod goes through lins and the created opers by replacing largest
possible subterms by the newly created identifiers
The optimization is invoked in gf by the flag i -subs.
If an application does not support GFC opers, the effect of this
optimization can be undone by the function unSubelimCanon.
The function unSubelimCanon can be used to diagnostisize how much
cse is possible in the grammar. It is used by the flag pg -printer=subs.
-}
subexpModule :: SourceModule -> SourceModule
subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of
MTAbstract -> return (m,mo)
_ -> do
let js = listJudgements mo
(tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0)
js2 <- addSubexpConsts m tree js
return (m, mo{mjments = Map.fromList js2})
unsubexpModule :: SourceModule -> SourceModule
unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)})
where
unparInfo (c, ju) = case jtype ju of
EInt 8 -> [] -- subexp-generated opers
_ -> [(c, ju {jdef = unparTerm (jdef ju)})]
unparTerm t = case t of
Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers
maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo)
_ -> C.composSafeOp unparTerm t
rebuild = Map.fromList . concat . map unparInfo . Map.assocs
-- implementation
type TermList = Map Term (Int,Int) -- number of occs, id
type TermM a = STM (TermList,Int) a
addSubexpConsts ::
Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)]
addSubexpConsts mo tree lins = do
let opers = [oper id trm | (trm,(_,id)) <- list]
mapM mkOne $ opers ++ lins
where
mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)})
recomp f t = case Map.lookup t tree of
Just (_,id) | ident id /= f -> Q mo (ident id)
_ -> C.composSafeOp (recomp f) t
list = Map.toList tree
oper id trm = (ident id, resOper (EInt 8) trm)
--- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int))
getSubtermsMod mo js = do
mapM (getInfo (collectSubterms mo)) js
(tree0,_) <- readSTM
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getInfo get fi@(_,i) = do
get (jdef i)
return $ fi
collectSubterms :: Ident -> Term -> TermM Term
collectSubterms mo t = case t of
App f a -> do
collect f
collect a
add t
T ty cs -> do
let (_,ts) = unzip cs
mapM collect ts
add t
V ty ts -> do
mapM collect ts
add t
---- K (KP _ _) -> add t
_ -> C.composOp (collectSubterms mo) t
where
collect = collectSubterms mo
add t = do
(ts,i) <- readSTM
let
((count,id),next) = case Map.lookup t ts of
Just (nu,id) -> ((nu+1,id), i)
_ -> ((1, i ), i+1)
writeSTM (Map.insert t (count,id) ts, next)
return t --- only because of composOp
ident :: Int -> Ident
ident i = identC ("_A" ++ show i) ---

326
src-3.0/GF/Devel/Compile/GF.cf
View File

@@ -1,326 +0,0 @@
-- AR 2/5/2003, 14-16 o'clock, Torino
-- 17/6/2007: marked with suffix --% those lines that are obsolete and
-- should not be included in documentation
entrypoints Grammar, ModDef,
OldGrammar, --%
Exp ; -- let's see if more are needed
comment "--" ;
comment "{-" "-}" ;
-- identifiers
position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ;
-- the top-level grammar
Gr. Grammar ::= [ModDef] ;
-- semicolon after module is permitted but not obligatory
terminator ModDef "" ;
_. ModDef ::= ModDef ";" ;
-- the individual modules
MModule. ModDef ::= ComplMod ModType "=" ModBody ;
MAbstract. ModType ::= "abstract" PIdent ;
MResource. ModType ::= "resource" PIdent ;
MGrammar. ModType ::= "grammar" PIdent ;
MInterface. ModType ::= "interface" PIdent ;
MConcrete. ModType ::= "concrete" PIdent "of" PIdent ;
MInstance. ModType ::= "instance" PIdent "of" PIdent ;
MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ;
MNoBody. ModBody ::= [Included] ;
MWith. ModBody ::= Included "with" [Open] ;
MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MWithE. ModBody ::= [Included] "**" Included "with" [Open] ;
MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MReuse. ModBody ::= "reuse" PIdent ; --%
MUnion. ModBody ::= "union" [Included] ;--%
separator TopDef "" ;
Ext. Extend ::= [Included] "**" ;
NoExt. Extend ::= ;
separator Open "," ;
NoOpens. Opens ::= ;
OpenIn. Opens ::= "open" [Open] "in" ;
OName. Open ::= PIdent ;
-- OQualQO. Open ::= "(" PIdent ")" ; --%
OQual. Open ::= "(" PIdent "=" PIdent ")" ;
CMCompl. ComplMod ::= ;
CMIncompl. ComplMod ::= "incomplete" ;
separator Included "," ;
IAll. Included ::= PIdent ;
ISome. Included ::= PIdent "[" [PIdent] "]" ;
IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ;
-- top-level definitions
DefCat. TopDef ::= "cat" [CatDef] ;
DefFun. TopDef ::= "fun" [FunDef] ;
DefFunData.TopDef ::= "data" [FunDef] ;
DefDef. TopDef ::= "def" [Def] ;
DefData. TopDef ::= "data" [DataDef] ;
DefPar. TopDef ::= "param" [ParDef] ;
DefOper. TopDef ::= "oper" [Def] ;
DefLincat. TopDef ::= "lincat" [Def] ;
DefLindef. TopDef ::= "lindef" [Def] ;
DefLin. TopDef ::= "lin" [Def] ;
DefPrintCat. TopDef ::= "printname" "cat" [Def] ;
DefPrintFun. TopDef ::= "printname" "fun" [Def] ;
DefFlag. TopDef ::= "flags" [Def] ;
-- definitions after most keywords
DDecl. Def ::= [Name] ":" Exp ;
DDef. Def ::= [Name] "=" Exp ;
DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list
DFull. Def ::= [Name] ":" Exp "=" Exp ;
FDecl. FunDef ::= [Name] ":" Exp ;
SimpleCatDef. CatDef ::= PIdent [DDecl] ;
ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ;
ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ;
DataDef. DataDef ::= Name "=" [DataConstr] ;
DataId. DataConstr ::= PIdent ;
DataQId. DataConstr ::= PIdent "." PIdent ;
separator DataConstr "|" ;
ParDefDir. ParDef ::= PIdent "=" [ParConstr] ;
ParDefAbs. ParDef ::= PIdent ;
ParConstr. ParConstr ::= PIdent [DDecl] ;
terminator nonempty Def ";" ;
terminator nonempty FunDef ";" ;
terminator nonempty CatDef ";" ;
terminator nonempty DataDef ";" ;
terminator nonempty ParDef ";" ;
separator ParConstr "|" ;
separator nonempty PIdent "," ;
-- names of categories and functions in definition LHS
PIdentName. Name ::= PIdent ;
ListName. Name ::= "[" PIdent "]" ;
separator nonempty Name "," ;
-- definitions in records and $let$ expressions
LDDecl. LocDef ::= [PIdent] ":" Exp ;
LDDef. LocDef ::= [PIdent] "=" Exp ;
LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ;
separator LocDef ";" ;
-- terms and types
EPIdent. Exp6 ::= PIdent ;
EConstr. Exp6 ::= "{" PIdent "}" ;--%
ECons. Exp6 ::= "%" PIdent "%" ;--%
ESort. Exp6 ::= Sort ;
EString. Exp6 ::= String ;
EInt. Exp6 ::= Integer ;
EFloat. Exp6 ::= Double ;
EMeta. Exp6 ::= "?" ;
EEmpty. Exp6 ::= "[" "]" ;
EData. Exp6 ::= "data" ;
EList. Exp6 ::= "[" PIdent Exps "]" ;
EStrings. Exp6 ::= "[" String "]" ;
ERecord. Exp6 ::= "{" [LocDef] "}" ; -- !
ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator ","
EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --%
ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations
EProj. Exp5 ::= Exp5 "." Label ;
EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --%
EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --%
EApp. Exp4 ::= Exp4 Exp5 ;
ETable. Exp4 ::= "table" "{" [Case] "}" ;
ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ;
EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; --%
EPatt. Exp4 ::= "pattern" Patt2 ;
EPattType. Exp4 ::= "pattern" "type" Exp5 ;
ESelect. Exp3 ::= Exp3 "!" Exp4 ;
ETupTyp. Exp3 ::= Exp3 "*" Exp4 ;
EExtend. Exp3 ::= Exp3 "**" Exp4 ;
EGlue. Exp1 ::= Exp2 "+" Exp1 ;
EConcat. Exp ::= Exp1 "++" Exp ;
EAbstr. Exp ::= "\\" [Bind] "->" Exp ;
ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ;
EProd. Exp ::= Decl "->" Exp ;
ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative
ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ;
ELetb. Exp ::= "let" [LocDef] "in" Exp ;
EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ;
EEqs. Exp ::= "fn" "{" [Equation] "}" ; --%
EExample. Exp ::= "in" Exp5 String ;
coercions Exp 6 ;
separator Exp ";" ; -- in variants
-- list of arguments to category
NilExp. Exps ::= ;
ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses
-- patterns
PChar. Patt2 ::= "?" ;
PChars. Patt2 ::= "[" String "]" ;
PMacro. Patt2 ::= "#" PIdent ;
PM. Patt2 ::= "#" PIdent "." PIdent ;
PW. Patt2 ::= "_" ;
PV. Patt2 ::= PIdent ;
PCon. Patt2 ::= "{" PIdent "}" ; --%
PQ. Patt2 ::= PIdent "." PIdent ;
PInt. Patt2 ::= Integer ;
PFloat. Patt2 ::= Double ;
PStr. Patt2 ::= String ;
PR. Patt2 ::= "{" [PattAss] "}" ;
PTup. Patt2 ::= "<" [PattTupleComp] ">" ;
PC. Patt1 ::= PIdent [Patt] ;
PQC. Patt1 ::= PIdent "." PIdent [Patt] ;
PDisj. Patt ::= Patt "|" Patt1 ;
PSeq. Patt ::= Patt "+" Patt1 ;
PRep. Patt1 ::= Patt2 "*" ;
PAs. Patt1 ::= PIdent "@" Patt2 ;
PNeg. Patt1 ::= "-" Patt2 ;
coercions Patt 2 ;
PA. PattAss ::= [PIdent] "=" Patt ;
-- labels
LPIdent. Label ::= PIdent ;
LVar. Label ::= "$" Integer ;
-- basic types
rules Sort ::=
"Type"
| "PType"
| "Tok" --%
| "Str"
| "Strs" ;
separator PattAss ";" ;
-- this is explicit to force higher precedence level on rhs
(:[]). [Patt] ::= Patt2 ;
(:). [Patt] ::= Patt2 [Patt] ;
-- binds in lambdas and lin rules
BPIdent. Bind ::= PIdent ;
BWild. Bind ::= "_" ;
separator Bind "," ;
-- declarations in function types
DDec. Decl ::= "(" [Bind] ":" Exp ")" ;
DExp. Decl ::= Exp4 ; -- can thus be an application
-- tuple component (term or pattern)
TComp. TupleComp ::= Exp ;
PTComp. PattTupleComp ::= Patt ;
separator TupleComp "," ;
separator PattTupleComp "," ;
-- case branches
Case. Case ::= Patt "=>" Exp ;
separator nonempty Case ";" ;
-- cases in abstract syntax --%
Equ. Equation ::= [Patt] "->" Exp ; --%
separator Equation ";" ; --%
-- prefix alternatives
Alt. Altern ::= Exp "/" Exp ;
separator Altern ";" ;
-- in a context, higher precedence is required than in function types
DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ;
DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application
separator DDecl "" ;
-------------------------------------- --%
-- for backward compatibility --%
OldGr. OldGrammar ::= Include [TopDef] ; --%
NoIncl. Include ::= ; --%
Incl. Include ::= "include" [FileName] ; --%
FString. FileName ::= String ; --%
terminator nonempty FileName ";" ; --%
FPIdent. FileName ::= PIdent ; --%
FSlash. FileName ::= "/" FileName ; --%
FDot. FileName ::= "." FileName ; --%
FMinus. FileName ::= "-" FileName ; --%
FAddId. FileName ::= PIdent FileName ; --%
token LString '\'' (char - '\'')* '\'' ; --%
ELString. Exp6 ::= LString ; --%
ELin. Exp4 ::= "Lin" PIdent ; --%
DefPrintOld. TopDef ::= "printname" [Def] ; --%
DefLintype. TopDef ::= "lintype" [Def] ; --%
DefPattern. TopDef ::= "pattern" [Def] ; --%
-- deprecated packages are attempted to be interpreted --%
DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --%
-- these two are just ignored after parsing --%
DefVars. TopDef ::= "var" [Def] ; --%
DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --%

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