GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-21 17:12:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

Added CFGM format (pm -printer=cfgm) and utf8 conversion for pm.

Browse Source
This commit is contained in:
bringert
2004-08-23 07:51:36 +00:00
parent 20215c7a49
commit 2af06fd3ab
22 changed files with 1829 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/GF/API.hs
View File

@@ -33,6 +33,7 @@ import ShellState
import Linear import Linear
import GFC import GFC
import qualified Grammar as G import qualified Grammar as G
import Modules
import PrGrammar import PrGrammar
import qualified Compute as Co import qualified Compute as Co
import qualified Ident as I import qualified Ident as I
@@ -284,13 +285,22 @@ prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts)
optPrintGrammar :: Options -> StateGrammar -> String optPrintGrammar :: Options -> StateGrammar -> String
optPrintGrammar opts = customOrDefault opts grammarPrinter customGrammarPrinter optPrintGrammar opts = customOrDefault opts grammarPrinter customGrammarPrinter
optPrintMultiGrammar :: Options -> CanonGrammar -> String
optPrintMultiGrammar opts = pmg . 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
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 :: Options -> GF.Grammar -> String
optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter
prCanonGrammar :: CanonGrammar -> String
prCanonGrammar = MC.prCanon
optPrintTree :: Options -> GFGrammar -> Tree -> String optPrintTree :: Options -> GFGrammar -> Tree -> String
optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter
@@ -328,13 +338,19 @@ optTokenizer opts gr = show . customOrDefault opts useTokenizer customTokenizer
-- performs UTF8 if the language does not have flag coding=utf8; replaces name*U -- 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 :: GFGrammar -> String -> String
optEncodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of optEncodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of
Just "utf8" -> id Just "utf8" -> id
_ -> encodeUTF8 _ -> encodeUTF8
-- convert a UTF8 encoded string into a Unicode string
optDecodeUTF8 :: GFGrammar -> String -> String optDecodeUTF8 :: GFGrammar -> String -> String
optDecodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of optDecodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of
Just "utf8" -> decodeUTF8 Just "utf8" -> decodeUTF8
_ -> id _ -> 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

50
src/GF/CFGM/AbsCFG.hs Normal file
View File

@@ -0,0 +1,50 @@
module AbsCFG where
-- Haskell module generated by the BNF converter
newtype Ident = Ident 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 Ident Name Profile Category [Symbol]
deriving (Eq,Ord,Show)
data Profile =
Profile [Ints]
deriving (Eq,Ord,Show)
data Ints =
Ints [Integer]
deriving (Eq,Ord,Show)
data Symbol =
CatS Category
| TermS String
deriving (Eq,Ord,Show)
data Name =
Name [IdentParam] Category
deriving (Eq,Ord,Show)
data Category =
Category IdentParam Ident [Param]
deriving (Eq,Ord,Show)
data IdentParam =
IdentParam Ident [Param]
deriving (Eq,Ord,Show)
data Param =
Param Ident
deriving (Eq,Ord,Show)

35
src/GF/CFGM/CFG.cf Normal file
View File

@@ -0,0 +1,35 @@
entrypoints Grammars;
Grammars. Grammars ::= [Grammar];
Grammar. Grammar ::= "grammar" Ident [Flag] [Rule] "end" "grammar";
separator Grammar "";
StartCat. Flag ::= "startcat" Category;
terminator Flag ";";
Rule. Rule ::= Ident ":" Name Profile "." Category "->" [Symbol];
terminator Rule ";";
Profile. Profile ::= "[" [Ints] "]";
Ints. Ints ::= "[" [Integer] "]";
separator Ints ",";
separator Integer ",";
CatS. Symbol ::= Category;
TermS. Symbol ::= String;
separator Symbol "";
Name. Name ::= [IdentParam] Category;
terminator IdentParam "/";
Category. Category ::= IdentParam "." Ident [Param] ;
IdentParam. IdentParam ::= Ident "{" [Param] "}" ;
Param. Param ::= "!" Ident ;
separator Param "";

273
src/GF/CFGM/LexCFG.hs Normal file
View File

@@ -0,0 +1,273 @@
{-# OPTIONS -cpp #-}
{-# LINE 3 "LexCFG.x" #-}
module LexCFG where
import ErrM
#if __GLASGOW_HASKELL__ >= 503
import Data.Array
import Data.Char (ord)
import Data.Array.Base (unsafeAt)
#else
import Array
import Char (ord)
#endif
alex_base :: Array Int Int
alex_base = listArray (0,11) [1,57,66,0,9,154,362,0,277,485,211,51]
alex_table :: Array Int Int
alex_table = listArray (0,740) [0,-1,-1,-1,-1,-1,-1,-1,-1,-1,2,2,2,2,2,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,2,3,8,-1,-1,-1,-1,-1,-1,-1,-1,-1,3,4,3,3,11,11,11,11,11,11,11,11,11,11,3,3,-1,-1,-1,-1,-1,2,2,2,2,2,3,0,0,0,2,2,2,2,2,0,0,0,0,0,0,0,0,0,2,0,0,3,-1,3,-1,-1,-1,2,11,11,11,11,11,11,11,11,11,11,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,-1,3,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,6,0,0,0,0,0,0,0,0,6,6,6,6,6,6,6,6,6,6,0,0,0,0,-1,0,0,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,9,0,0,-1,6,9,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,0,0,0,0,0,0,0,0,0,0,-1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,9,0,0,0,0,0,0,0,7,0,0,0,0,0,0,0,0,0,9,0,0,0,0,0,9,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,10,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,0,0,0,0,0,0,0,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,0,0,0,0,6,0,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,0,0,0,0,0,0,0,0,0,0,-1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,7,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,10,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,0,6,6,6,6,6,6,6,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
alex_check :: Array Int Int
alex_check = listArray (0,740) [-1,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,9,10,11,12,13,62,-1,-1,-1,9,10,11,12,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,-1,-1,91,92,93,94,95,96,32,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,215,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,34,-1,-1,247,95,39,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,10,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,-1,-1,-1,-1,-1,-1,-1,34,-1,-1,-1,-1,-1,-1,-1,-1,-1,110,-1,-1,-1,-1,-1,116,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,92,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,39,248,249,250,251,252,253,254,255,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,10,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,34,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,92,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,-1,248,249,250,251,252,253,254,255,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1]
alex_deflt :: Array Int Int
alex_deflt = listArray (0,11) [5,-1,-1,-1,-1,-1,-1,-1,9,9,-1,-1]
alex_accept = listArray (0::Int,11) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[],[(AlexAcc (alex_action_4))]]
{-# LINE 31 "LexCFG.x" #-}
tok f p s = f p s
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)
data Token =
PT Posn Tok
| Err Posn
deriving Show
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
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "grammar" (B "end" N N) (B "startcat" N N)
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
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)
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 s))
alex_action_2 = tok (\p s -> PT p (eitherResIdent TV s))
alex_action_3 = tok (\p s -> PT p (TL $ unescapeInitTail s))
alex_action_4 = tok (\p s -> PT p (TI 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 23 "GenericTemplate.hs" #-}
{-# LINE 35 "GenericTemplate.hs" #-}
{-# LINE 44 "GenericTemplate.hs" #-}
{-# LINE 67 "GenericTemplate.hs" #-}
alexIndexShortOffAddr arr off = arr ! off
-- -----------------------------------------------------------------------------
-- 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 (sc)
= alexScanUser undefined input (sc)
alexScanUser user input (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 `unsafeAt` (s))
in
new_acc `seq`
case alexGetChar input of
Nothing -> (new_acc, input)
Just (c, new_input) ->
let
base = alexIndexShortOffAddr alex_base s
(ord_c) = ord c
offset = (base + ord_c)
check = alexIndexShortOffAddr alex_check offset
new_s = if (offset >= (0)) && (check == ord_c)
then alexIndexShortOffAddr alex_table offset
else alexIndexShortOffAddr 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 (len)
check_accs (AlexAccSkip : _) = AlexLastSkip input (len)
check_accs (AlexAccPred a pred : rest)
| pred user orig_input (len) input
= AlexLastAcc a input (len)
check_accs (AlexAccSkipPred pred : rest)
| pred user orig_input (len) input
= AlexLastSkip input (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 (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

129
src/GF/CFGM/LexCFG.x Normal file
View File

@@ -0,0 +1,129 @@
-- -*- 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 s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent TV s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI s)) }
{
tok f p s = f p s
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)
data Token =
PT Posn Tok
| Err Posn
deriving Show
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
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "grammar" (B "end" N N) (B "startcat" N N)
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
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)
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
}

766
src/GF/CFGM/ParCFG.hs Normal file
View File

@@ -0,0 +1,766 @@
-- parser produced by Happy Version 1.13
module ParCFG where
import AbsCFG
import LexCFG
import ErrM
data HappyAbsSyn t4 t5 t6
= HappyTerminal Token
| HappyErrorToken Int
| HappyAbsSyn4 t4
| HappyAbsSyn5 t5
| HappyAbsSyn6 t6
| HappyAbsSyn7 (Grammars)
| HappyAbsSyn8 (Grammar)
| HappyAbsSyn9 ([Grammar])
| HappyAbsSyn10 (Flag)
| HappyAbsSyn11 ([Flag])
| HappyAbsSyn12 (Rule)
| HappyAbsSyn13 ([Rule])
| HappyAbsSyn14 (Profile)
| HappyAbsSyn15 (Ints)
| HappyAbsSyn16 ([Ints])
| HappyAbsSyn17 ([Integer])
| HappyAbsSyn18 (Symbol)
| HappyAbsSyn19 ([Symbol])
| HappyAbsSyn20 (Name)
| HappyAbsSyn21 ([IdentParam])
| HappyAbsSyn22 (Category)
| HappyAbsSyn23 (IdentParam)
| HappyAbsSyn24 (Param)
| HappyAbsSyn25 ([Param])
action_0 (7) = happyGoto action_3
action_0 (9) = happyGoto action_4
action_0 _ = happyReduce_6
action_1 (40) = happyShift action_2
action_1 _ = happyFail
action_2 _ = happyReduce_1
action_3 (44) = happyAccept
action_3 _ = happyFail
action_4 (38) = happyShift action_6
action_4 (8) = happyGoto action_5
action_4 _ = happyReduce_4
action_5 _ = happyReduce_7
action_6 (40) = happyShift action_2
action_6 (4) = happyGoto action_7
action_6 _ = happyFail
action_7 (11) = happyGoto action_8
action_7 _ = happyReduce_9
action_8 (39) = happyShift action_11
action_8 (10) = happyGoto action_9
action_8 (13) = happyGoto action_10
action_8 _ = happyReduce_12
action_9 (26) = happyShift action_18
action_9 _ = happyFail
action_10 (37) = happyShift action_17
action_10 (40) = happyShift action_2
action_10 (4) = happyGoto action_15
action_10 (12) = happyGoto action_16
action_10 _ = happyFail
action_11 (40) = happyShift action_2
action_11 (4) = happyGoto action_12
action_11 (22) = happyGoto action_13
action_11 (23) = happyGoto action_14
action_11 _ = happyFail
action_12 (34) = happyShift action_23
action_12 _ = happyFail
action_13 _ = happyReduce_8
action_14 (28) = happyShift action_22
action_14 _ = happyFail
action_15 (27) = happyShift action_21
action_15 _ = happyFail
action_16 (26) = happyShift action_20
action_16 _ = happyFail
action_17 (38) = happyShift action_19
action_17 _ = happyFail
action_18 _ = happyReduce_10
action_19 _ = happyReduce_5
action_20 _ = happyReduce_13
action_21 (20) = happyGoto action_26
action_21 (21) = happyGoto action_27
action_21 _ = happyReduce_27
action_22 (40) = happyShift action_2
action_22 (4) = happyGoto action_25
action_22 _ = happyFail
action_23 (25) = happyGoto action_24
action_23 _ = happyReduce_32
action_24 (35) = happyShift action_34
action_24 (36) = happyShift action_35
action_24 (24) = happyGoto action_33
action_24 _ = happyFail
action_25 (25) = happyGoto action_32
action_25 _ = happyReduce_32
action_26 (30) = happyShift action_31
action_26 (14) = happyGoto action_30
action_26 _ = happyFail
action_27 (40) = happyShift action_2
action_27 (4) = happyGoto action_12
action_27 (22) = happyGoto action_28
action_27 (23) = happyGoto action_29
action_27 _ = happyFail
action_28 _ = happyReduce_26
action_29 (28) = happyShift action_22
action_29 (33) = happyShift action_41
action_29 _ = happyFail
action_30 (28) = happyShift action_40
action_30 _ = happyFail
action_31 (30) = happyShift action_39
action_31 (15) = happyGoto action_37
action_31 (16) = happyGoto action_38
action_31 _ = happyReduce_16
action_32 (36) = happyShift action_35
action_32 (24) = happyGoto action_33
action_32 _ = happyReduce_29
action_33 _ = happyReduce_33
action_34 _ = happyReduce_30
action_35 (40) = happyShift action_2
action_35 (4) = happyGoto action_36
action_35 _ = happyFail
action_36 _ = happyReduce_31
action_37 (32) = happyShift action_47
action_37 _ = happyReduce_17
action_38 (31) = happyShift action_46
action_38 _ = happyFail
action_39 (41) = happyShift action_45
action_39 (5) = happyGoto action_43
action_39 (17) = happyGoto action_44
action_39 _ = happyReduce_19
action_40 (40) = happyShift action_2
action_40 (4) = happyGoto action_12
action_40 (22) = happyGoto action_42
action_40 (23) = happyGoto action_14
action_40 _ = happyFail
action_41 _ = happyReduce_28
action_42 (29) = happyShift action_51
action_42 _ = happyFail
action_43 (32) = happyShift action_50
action_43 _ = happyReduce_20
action_44 (31) = happyShift action_49
action_44 _ = happyFail
action_45 _ = happyReduce_2
action_46 _ = happyReduce_14
action_47 (30) = happyShift action_39
action_47 (15) = happyGoto action_37
action_47 (16) = happyGoto action_48
action_47 _ = happyReduce_16
action_48 _ = happyReduce_18
action_49 _ = happyReduce_15
action_50 (41) = happyShift action_45
action_50 (5) = happyGoto action_43
action_50 (17) = happyGoto action_53
action_50 _ = happyReduce_19
action_51 (19) = happyGoto action_52
action_51 _ = happyReduce_24
action_52 (40) = happyShift action_2
action_52 (42) = happyShift action_57
action_52 (4) = happyGoto action_12
action_52 (6) = happyGoto action_54
action_52 (18) = happyGoto action_55
action_52 (22) = happyGoto action_56
action_52 (23) = happyGoto action_14
action_52 _ = happyReduce_11
action_53 _ = happyReduce_21
action_54 _ = happyReduce_23
action_55 _ = happyReduce_25
action_56 _ = happyReduce_22
action_57 _ = happyReduce_3
happyReduce_1 = happySpecReduce_1 4 happyReduction_1
happyReduction_1 (HappyTerminal (PT _ (TV happy_var_1)))
= HappyAbsSyn4
(Ident happy_var_1
)
happyReduction_1 _ = notHappyAtAll
happyReduce_2 = happySpecReduce_1 5 happyReduction_2
happyReduction_2 (HappyTerminal (PT _ (TI happy_var_1)))
= HappyAbsSyn5
((read happy_var_1) :: Integer
)
happyReduction_2 _ = notHappyAtAll
happyReduce_3 = happySpecReduce_1 6 happyReduction_3
happyReduction_3 (HappyTerminal (PT _ (TL happy_var_1)))
= HappyAbsSyn6
(happy_var_1
)
happyReduction_3 _ = notHappyAtAll
happyReduce_4 = happySpecReduce_1 7 happyReduction_4
happyReduction_4 (HappyAbsSyn9 happy_var_1)
= HappyAbsSyn7
(Grammars (reverse happy_var_1)
)
happyReduction_4 _ = notHappyAtAll
happyReduce_5 = happyReduce 6 8 happyReduction_5
happyReduction_5 (_ `HappyStk`
_ `HappyStk`
(HappyAbsSyn13 happy_var_4) `HappyStk`
(HappyAbsSyn11 happy_var_3) `HappyStk`
(HappyAbsSyn4 happy_var_2) `HappyStk`
_ `HappyStk`
happyRest)
= HappyAbsSyn8
(Grammar happy_var_2 (reverse happy_var_3) (reverse happy_var_4)
) `HappyStk` happyRest
happyReduce_6 = happySpecReduce_0 9 happyReduction_6
happyReduction_6 = HappyAbsSyn9
([]
)
happyReduce_7 = happySpecReduce_2 9 happyReduction_7
happyReduction_7 (HappyAbsSyn8 happy_var_2)
(HappyAbsSyn9 happy_var_1)
= HappyAbsSyn9
(flip (:) happy_var_1 happy_var_2
)
happyReduction_7 _ _ = notHappyAtAll
happyReduce_8 = happySpecReduce_2 10 happyReduction_8
happyReduction_8 (HappyAbsSyn22 happy_var_2)
_
= HappyAbsSyn10
(StartCat happy_var_2
)
happyReduction_8 _ _ = notHappyAtAll
happyReduce_9 = happySpecReduce_0 11 happyReduction_9
happyReduction_9 = HappyAbsSyn11
([]
)
happyReduce_10 = happySpecReduce_3 11 happyReduction_10
happyReduction_10 _
(HappyAbsSyn10 happy_var_2)
(HappyAbsSyn11 happy_var_1)
= HappyAbsSyn11
(flip (:) happy_var_1 happy_var_2
)
happyReduction_10 _ _ _ = notHappyAtAll
happyReduce_11 = happyReduce 8 12 happyReduction_11
happyReduction_11 ((HappyAbsSyn19 happy_var_8) `HappyStk`
_ `HappyStk`
(HappyAbsSyn22 happy_var_6) `HappyStk`
_ `HappyStk`
(HappyAbsSyn14 happy_var_4) `HappyStk`
(HappyAbsSyn20 happy_var_3) `HappyStk`
_ `HappyStk`
(HappyAbsSyn4 happy_var_1) `HappyStk`
happyRest)
= HappyAbsSyn12
(Rule happy_var_1 happy_var_3 happy_var_4 happy_var_6 (reverse happy_var_8)
) `HappyStk` happyRest
happyReduce_12 = happySpecReduce_0 13 happyReduction_12
happyReduction_12 = HappyAbsSyn13
([]
)
happyReduce_13 = happySpecReduce_3 13 happyReduction_13
happyReduction_13 _
(HappyAbsSyn12 happy_var_2)
(HappyAbsSyn13 happy_var_1)
= HappyAbsSyn13
(flip (:) happy_var_1 happy_var_2
)
happyReduction_13 _ _ _ = notHappyAtAll
happyReduce_14 = happySpecReduce_3 14 happyReduction_14
happyReduction_14 _
(HappyAbsSyn16 happy_var_2)
_
= HappyAbsSyn14
(Profile happy_var_2
)
happyReduction_14 _ _ _ = notHappyAtAll
happyReduce_15 = happySpecReduce_3 15 happyReduction_15
happyReduction_15 _
(HappyAbsSyn17 happy_var_2)
_
= HappyAbsSyn15
(Ints happy_var_2
)
happyReduction_15 _ _ _ = notHappyAtAll
happyReduce_16 = happySpecReduce_0 16 happyReduction_16
happyReduction_16 = HappyAbsSyn16
([]
)
happyReduce_17 = happySpecReduce_1 16 happyReduction_17
happyReduction_17 (HappyAbsSyn15 happy_var_1)
= HappyAbsSyn16
((:[]) happy_var_1
)
happyReduction_17 _ = notHappyAtAll
happyReduce_18 = happySpecReduce_3 16 happyReduction_18
happyReduction_18 (HappyAbsSyn16 happy_var_3)
_
(HappyAbsSyn15 happy_var_1)
= HappyAbsSyn16
((:) happy_var_1 happy_var_3
)
happyReduction_18 _ _ _ = notHappyAtAll
happyReduce_19 = happySpecReduce_0 17 happyReduction_19
happyReduction_19 = HappyAbsSyn17
([]
)
happyReduce_20 = happySpecReduce_1 17 happyReduction_20
happyReduction_20 (HappyAbsSyn5 happy_var_1)
= HappyAbsSyn17
((:[]) happy_var_1
)
happyReduction_20 _ = notHappyAtAll
happyReduce_21 = happySpecReduce_3 17 happyReduction_21
happyReduction_21 (HappyAbsSyn17 happy_var_3)
_
(HappyAbsSyn5 happy_var_1)
= HappyAbsSyn17
((:) happy_var_1 happy_var_3
)
happyReduction_21 _ _ _ = notHappyAtAll
happyReduce_22 = happySpecReduce_1 18 happyReduction_22
happyReduction_22 (HappyAbsSyn22 happy_var_1)
= HappyAbsSyn18
(CatS happy_var_1
)
happyReduction_22 _ = notHappyAtAll
happyReduce_23 = happySpecReduce_1 18 happyReduction_23
happyReduction_23 (HappyAbsSyn6 happy_var_1)
= HappyAbsSyn18
(TermS happy_var_1
)
happyReduction_23 _ = notHappyAtAll
happyReduce_24 = happySpecReduce_0 19 happyReduction_24
happyReduction_24 = HappyAbsSyn19
([]
)
happyReduce_25 = happySpecReduce_2 19 happyReduction_25
happyReduction_25 (HappyAbsSyn18 happy_var_2)
(HappyAbsSyn19 happy_var_1)
= HappyAbsSyn19
(flip (:) happy_var_1 happy_var_2
)
happyReduction_25 _ _ = notHappyAtAll
happyReduce_26 = happySpecReduce_2 20 happyReduction_26
happyReduction_26 (HappyAbsSyn22 happy_var_2)
(HappyAbsSyn21 happy_var_1)
= HappyAbsSyn20
(Name (reverse happy_var_1) happy_var_2
)
happyReduction_26 _ _ = notHappyAtAll
happyReduce_27 = happySpecReduce_0 21 happyReduction_27
happyReduction_27 = HappyAbsSyn21
([]
)
happyReduce_28 = happySpecReduce_3 21 happyReduction_28
happyReduction_28 _
(HappyAbsSyn23 happy_var_2)
(HappyAbsSyn21 happy_var_1)
= HappyAbsSyn21
(flip (:) happy_var_1 happy_var_2
)
happyReduction_28 _ _ _ = notHappyAtAll
happyReduce_29 = happyReduce 4 22 happyReduction_29
happyReduction_29 ((HappyAbsSyn25 happy_var_4) `HappyStk`
(HappyAbsSyn4 happy_var_3) `HappyStk`
_ `HappyStk`
(HappyAbsSyn23 happy_var_1) `HappyStk`
happyRest)
= HappyAbsSyn22
(Category happy_var_1 happy_var_3 (reverse happy_var_4)
) `HappyStk` happyRest
happyReduce_30 = happyReduce 4 23 happyReduction_30
happyReduction_30 (_ `HappyStk`
(HappyAbsSyn25 happy_var_3) `HappyStk`
_ `HappyStk`
(HappyAbsSyn4 happy_var_1) `HappyStk`
happyRest)
= HappyAbsSyn23
(IdentParam happy_var_1 (reverse happy_var_3)
) `HappyStk` happyRest
happyReduce_31 = happySpecReduce_2 24 happyReduction_31
happyReduction_31 (HappyAbsSyn4 happy_var_2)
_
= HappyAbsSyn24
(Param happy_var_2
)
happyReduction_31 _ _ = notHappyAtAll
happyReduce_32 = happySpecReduce_0 25 happyReduction_32
happyReduction_32 = HappyAbsSyn25
([]
)
happyReduce_33 = happySpecReduce_2 25 happyReduction_33
happyReduction_33 (HappyAbsSyn24 happy_var_2)
(HappyAbsSyn25 happy_var_1)
= HappyAbsSyn25
(flip (:) happy_var_1 happy_var_2
)
happyReduction_33 _ _ = notHappyAtAll
happyNewToken action sts stk [] =
action 44 44 (error "reading EOF!") (HappyState action) sts stk []
happyNewToken action sts stk (tk:tks) =
let cont i = action i i tk (HappyState action) sts stk tks in
case tk of {
PT _ (TS ";") -> cont 26;
PT _ (TS ":") -> cont 27;
PT _ (TS ".") -> cont 28;
PT _ (TS "->") -> cont 29;
PT _ (TS "[") -> cont 30;
PT _ (TS "]") -> cont 31;
PT _ (TS ",") -> cont 32;
PT _ (TS "/") -> cont 33;
PT _ (TS "{") -> cont 34;
PT _ (TS "}") -> cont 35;
PT _ (TS "!") -> cont 36;
PT _ (TS "end") -> cont 37;
PT _ (TS "grammar") -> cont 38;
PT _ (TS "startcat") -> cont 39;
PT _ (TV happy_dollar_dollar) -> cont 40;
PT _ (TI happy_dollar_dollar) -> cont 41;
PT _ (TL happy_dollar_dollar) -> cont 42;
_ -> cont 43;
_ -> happyError 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 tks -> (returnM) a
pGrammars tks = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn7 z -> happyReturn z; _other -> notHappyAtAll })
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.1 2004/08/23 08:51:37 bringert Exp $
{-# LINE 15 "GenericTemplate.hs" #-}
infixr 9 `HappyStk`
data HappyStk a = HappyStk a (HappyStk a)
-----------------------------------------------------------------------------
-- starting the parse
happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
-----------------------------------------------------------------------------
-- Accepting the parse
happyAccept j tk st sts (HappyStk ans _) =
(happyReturn1 ans)
-----------------------------------------------------------------------------
-- Arrays only: do the next action
{-# LINE 150 "GenericTemplate.hs" #-}
-----------------------------------------------------------------------------
-- HappyState data type (not arrays)
newtype HappyState b c = HappyState
(Int -> -- token number
Int -> -- token number (yes, again)
b -> -- token semantic value
HappyState b c -> -- current state
[HappyState b c] -> -- state stack
c)
-----------------------------------------------------------------------------
-- Shifting a token
happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =
let i = (case x of { HappyErrorToken (i) -> i }) in
-- trace "shifting the error token" $
new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)
happyShift new_state i tk st sts stk =
happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)
-- happyReduce is specialised for the common cases.
happySpecReduce_0 i fn (1) tk st sts stk
= happyFail (1) tk st sts stk
happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk
= action nt j tk st ((st):(sts)) (fn `HappyStk` stk)
happySpecReduce_1 i fn (1) tk st sts stk
= happyFail (1) tk st sts stk
happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')
= let r = fn v1 in
happySeq r (action nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_2 i fn (1) tk st sts stk
= happyFail (1) tk st sts stk
happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')
= let r = fn v1 v2 in
happySeq r (action nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_3 i fn (1) tk st sts stk
= happyFail (1) tk st sts stk
happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
= let r = fn v1 v2 v3 in
happySeq r (action nt j tk st sts (r `HappyStk` stk'))
happyReduce k i fn (1) tk st sts stk
= happyFail (1) tk st sts stk
happyReduce k nt fn j tk st sts stk
= case happyDrop (k - ((1) :: Int)) sts of
sts1@(((st1@(HappyState (action))):(_))) ->
let r = fn stk in -- it doesn't hurt to always seq here...
happyDoSeq r (action nt j tk st1 sts1 r)
happyMonadReduce k nt fn (1) tk st sts stk
= happyFail (1) tk st sts stk
happyMonadReduce k nt fn j tk st sts stk =
happyThen1 (fn stk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
drop_stk = happyDropStk k stk
happyDrop (0) l = l
happyDrop n ((_):(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 action j tk st = action j j tk (HappyState action)
-----------------------------------------------------------------------------
-- Error recovery ((1) is the error token)
-- parse error if we are in recovery and we fail again
happyFail (1) tk old_st _ stk =
-- trace "failing" $
happyError
{- 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 (1) tk old_st (((HappyState (action))):(sts))
(saved_tok `HappyStk` _ `HappyStk` stk) =
-- trace ("discarding state, depth " ++ show (length stk)) $
action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
-}
-- Enter error recovery: generate an error token,
-- save the old token and carry on.
happyFail i tk (HappyState (action)) sts stk =
-- trace "entering error recovery" $
action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)
-- Internal happy errors:
notHappyAtAll = error "Internal Happy error\n"
-----------------------------------------------------------------------------
-- Hack to get the typechecker to accept our action functions
-----------------------------------------------------------------------------
-- 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 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.

144
src/GF/CFGM/ParCFG.y Normal file
View File

@@ -0,0 +1,144 @@
-- This Happy file was machine-generated by the BNF converter
{
module ParCFG where
import AbsCFG
import LexCFG
import ErrM
}
%name pGrammars Grammars
%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 "!") }
'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_err { _ }
%%
Ident : L_ident { Ident $1 }
Integer : L_integ { (read $1) :: Integer }
String : L_quoted { $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 : Ident ':' Name Profile '.' Category '->' ListSymbol { Rule $1 $3 $4 $6 (reverse $8) }
ListRule :: { [Rule] }
ListRule : {- empty -} { [] }
| ListRule Rule ';' { flip (:) $1 $2 }
Profile :: { Profile }
Profile : '[' ListInts ']' { Profile $2 }
Ints :: { Ints }
Ints : '[' ListInteger ']' { Ints $2 }
ListInts :: { [Ints] }
ListInts : {- empty -} { [] }
| Ints { (:[]) $1 }
| Ints ',' ListInts { (:) $1 $3 }
ListInteger :: { [Integer] }
ListInteger : {- empty -} { [] }
| Integer { (:[]) $1 }
| Integer ',' ListInteger { (:) $1 $3 }
Symbol :: { Symbol }
Symbol : Category { CatS $1 }
| String { TermS $1 }
ListSymbol :: { [Symbol] }
ListSymbol : {- empty -} { [] }
| ListSymbol Symbol { flip (:) $1 $2 }
Name :: { Name }
Name : ListIdentParam Category { Name (reverse $1) $2 }
ListIdentParam :: { [IdentParam] }
ListIdentParam : {- empty -} { [] }
| ListIdentParam IdentParam '/' { flip (:) $1 $2 }
Category :: { Category }
Category : IdentParam '.' Ident ListParam { Category $1 $3 (reverse $4) }
IdentParam :: { IdentParam }
IdentParam : Ident '{' ListParam '}' { IdentParam $1 (reverse $3) }
Param :: { Param }
Param : '!' Ident { Param $2 }
ListParam :: { [Param] }
ListParam : {- empty -} { [] }
| ListParam Param { flip (:) $1 $2 }
{
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
}

164
src/GF/CFGM/PrintCFG.hs Normal file
View File

@@ -0,0 +1,164 @@
module PrintCFG where
-- pretty-printer generated by the BNF converter
import 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 = (:)
-- seriously hacked spacing
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
";" :ts -> showString ";" . new i . rend i ts
-- H removed a bunch of cases here
"]":".":ts -> showString "]" . space "." . rend i ts -- H
t:t' :ts | noSpace t' -> showString t . showString t' . rend i ts -- H
t :ts | noSpace t -> showString t . rend i ts -- H
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))
noSpace t = t `elem` ["[","]","{","}",",","/",":",".","!"] -- 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 = 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 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 id name profile category symbols -> prPrec i 0 (concatD [prt 0 id , doc (showString ":") , prt 0 name , prt 0 profile , 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 Profile where
prt i e = case e of
Profile intss -> prPrec i 0 (concatD [doc (showString "[") , prt 0 intss , doc (showString "]")])
instance Print Ints where
prt i e = case e of
Ints ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print 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 [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Name where
prt i e = case e of
Name identparams category -> prPrec i 0 (concatD [prt 0 identparams , prt 0 category])
instance Print Category where
prt i e = case e of
Category identparam id params -> prPrec i 0 (concatD [prt 0 identparam , doc (showString ".") , prt 0 id , prt 0 params])
instance Print IdentParam where
prt i e = case e of
IdentParam id params -> prPrec i 0 (concatD [prt 0 id , doc (showString "{") , prt 0 params , doc (showString "}")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString "/") , prt 0 xs])
instance Print Param where
prt i e = case e of
Param id -> prPrec i 0 (concatD [doc (showString "!") , prt 0 id])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])

33
src/GF/CFGM/PrintCFGrammar.hs Normal file
View File

@@ -0,0 +1,33 @@
-- Handles printing a CFGrammar in CFGM format.
module PrintCFGrammar (prCanonAsCFGM) where
import AbsGFC
import Ident
import GFC
import Modules
import qualified ConvertGrammar as Cnv
import qualified PrintParser as Prt
import List (intersperse)
import Maybe (listToMaybe, fromMaybe)
-- FIXME: fix warning about bad -printer= value
prCanonAsCFGM :: CanonGrammar -> String
prCanonAsCFGM gr = unlines $ map (uncurry (prLangAsCFGM gr)) xs
where
xs = [(i,getFlag fs "startcat") | (i,ModMod (Module{mtype=MTConcrete _,flags=fs})) <- modules gr]
-- 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]
prLangAsCFGM :: CanonGrammar -> Ident -> Maybe String -> String
prLangAsCFGM gr i@(IC lang) start = (header . startcat . rules . footer) ""
where
header = showString "grammar " . showString lang . showString "\n"
startcat = maybe id (\s -> showString "startcat " . showString (s++"{}.s") . showString ";\n") start
rules0 = map Prt.prt $ Cnv.cfg $ Cnv.pInfo gr i
rules = showString $ concat $ map (\l -> init l++";\n") rules0
footer = showString "end grammar\n"

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

@@ -178,3 +178,56 @@ wordsInTerm trm = filter (not . null) $ case trm of
P t _ -> wo t --- not needed ? P t _ -> wo t --- not needed ?
_ -> [] _ -> []
where wo = wordsInTerm 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
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm =
case trm of
Con x as ->
do
as' <- mapM co as
return (Con 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')
_ -> return trm -- covers Arg, I, LI, K, E

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

@@ -47,3 +47,70 @@ prCanonModInfo = printTree . info2mod
prGrammar :: CanonGrammar -> String prGrammar :: CanonGrammar -> String
prGrammar = printTree . grammar2canon prGrammar = printTree . grammar2canon
-} -}
{-
-- apply a function to all concrete terms in a grammar
mapConcreteTerms :: (Term -> Term) -> CanonGrammar -> CanonGrammar
mapConcreteTerms f (M.MGrammar xs) = M.MGrammar $ map (onSnd (onModule f)) xs
where
onModule :: (Term -> Term) -> M.ModInfo i f Info -> M.ModInfo i f Info
onModule f m = case m of
M.ModMod (m@M.Module{M.jments=js}) ->
M.ModMod (m{ M.jments = mapTree (onSnd (onInfo f)) js })
_ -> m
-- if -utf8 was given, convert from language specific coding
encode = if oElem useUTF8 opts then setUTF8Flag . canonUTF8 else id
canonUTF8 = mapConcreteTerms (onTokens (anyCodingToUTF8 opts))
setUTF8Flag = setFlag "coding" "utf8"
moduleToUTF8 :: Module Ident Flag Info -> Module Ident Flag Info
moduleToUTF8 m = m{ jments = mapTree (onSnd }
where
code = anyCodingToUTF8 (moduleOpts m)
moduleOpts = okError . mapM redFlag . flags
data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]}
deriving Show
data ModInfo i f a =
ModMainGrammar (MainGrammar i)
| ModMod (Module i f a)
| ModWith (ModuleType i) ModuleStatus i [OpenSpec i]
deriving Show
data Module i f a = Module {
mtype :: ModuleType i ,
mstatus :: ModuleStatus ,
flags :: [f] ,
extends :: Maybe i ,
opens :: [OpenSpec i] ,
jments :: BinTree (i,a)
}
deriving Show
-- Set a flag in all modules in a grammar
setFlag :: String -> String -> CanonGrammar -> CanonGrammar
setFlag n v (M.MGrammar ms) = M.MGrammar $ map (onSnd setFlagMod) ms
where
setFlagMod m = case m of
M.ModMod (m@M.Module{M.flags=fs}) -> M.ModMod $ m{ M.flags = fs' }
where fs' = Flg (IC n) (IC v):[f | f@(Flg (IC n') _) <- fs, n' /= n]
_ -> m
-}
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 = Flg (IC n) (IC v):[f | f@(Flg (IC n') _) <- fs, n' /= n]

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

@@ -69,12 +69,13 @@ instance Print Double where
prt _ x = doc (shows x) prt _ x = doc (shows x)
instance Print Char where instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc s . showChar '\'') prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map mkEsc s) . showChar '"') prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> ShowS mkEsc :: Char -> Char -> ShowS
mkEsc s = case s of mkEsc q s = case s of
_ | elem s "\\\"'" -> showChar '\\' . showChar s _ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n" '\n' -> showString "\\n"
'\t' -> showString "\\t" '\t' -> showString "\\t"
_ -> showChar s _ -> showChar s

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

@@ -16,6 +16,9 @@ infixl 9 !?
ifNull :: b -> ([a] -> b) -> [a] -> b ifNull :: b -> ([a] -> b) -> [a] -> b
ifNull b f xs = if null xs then b else f xs ifNull b f xs = if null xs then b else f xs
onSnd :: (a -> b) -> (c,a) -> (c,b)
onSnd f (x, y) = (x, f y)
-- the Error monad -- the Error monad
data Err a = Ok a | Bad String -- like Maybe type with error msgs data Err a = Ok a | Bad String -- like Maybe type with error msgs

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

@@ -75,6 +75,12 @@ addOpenQualif i j (Module mt ms fs me ops js) =
allFlags :: MGrammar i f a -> [f] allFlags :: MGrammar i f a -> [f]
allFlags gr = concat $ map flags $ reverse [m | (_, ModMod m) <- modules gr] allFlags gr = concat $ map flags $ reverse [m | (_, ModMod m) <- modules gr]
mapModules :: (Module i f a -> Module i f a)
-> MGrammar i f a -> MGrammar i f a
mapModules f = MGrammar . map (onSnd mapModules') . modules
where mapModules' (ModMod m) = ModMod (f m)
mapModules' m = m
data MainGrammar i = MainGrammar { data MainGrammar i = MainGrammar {
mainAbstract :: i , mainAbstract :: i ,
mainConcretes :: [MainConcreteSpec i] mainConcretes :: [MainConcreteSpec i]

2
src/GF/Shell.hs
View File

@@ -220,7 +220,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
(putStrLn $ unwords $ map prLanguage $ allLanguages st) sa (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa
CPrintMultiGrammar -> do CPrintMultiGrammar -> do
sa' <- changeState purgeShellState sa sa' <- changeState purgeShellState sa
returnArg (AString (prCanonGrammar (canModules st))) sa' returnArg (AString (optPrintMultiGrammar opts cgr)) sa'
---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa ---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa
---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa ---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa

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

@@ -162,7 +162,7 @@ optionsOfCommand co = case co of
CSystemCommand _ -> none CSystemCommand _ -> none
CPrintGrammar -> both "utf8" "printer lang" CPrintGrammar -> both "utf8" "printer lang"
CPrintMultiGrammar -> opts "utf8" CPrintMultiGrammar -> both "utf8" "printer"
CHelp _ -> opts "all" CHelp _ -> opts "all"

11
src/GF/Source/PrintGF.hs
View File

@@ -66,12 +66,13 @@ instance Print Double where
prt _ x = doc (shows x) prt _ x = doc (shows x)
instance Print Char where instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc s . showChar '\'') prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map mkEsc s) . showChar '"') prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> ShowS mkEsc :: Char -> Char -> ShowS
mkEsc s = case s of mkEsc q s = case s of
_ | elem s "\\\"" -> showChar '\\' . showChar s -- H (don't escape ') _ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n" '\n' -> showString "\\n"
'\t' -> showString "\\t" '\t' -> showString "\\t"
_ -> showChar s _ -> showChar s

1
src/GF/Text/Unicode.hs
View File

@@ -45,6 +45,7 @@ mkUnicode s = case s of
_ -> (reverse u,[]) -- forgiving missing end _ -> (reverse u,[]) -- forgiving missing end
-- don't convert XML tags --- assumes <> always means XML tags -- don't convert XML tags --- assumes <> always means XML tags
treat :: String -> (String -> String) -> String -> String
treat old mk s = case s of treat old mk s = case s of
'<':cs -> mk (reverse old) ++ '<':noTreat cs '<':cs -> mk (reverse old) ++ '<':noTreat cs
c:cs -> treat (c:old) mk cs c:cs -> treat (c:old) mk cs

59
src/GF/UseGrammar/Custom.hs
View File

@@ -47,6 +47,10 @@ import qualified ParseCF as PCF
import qualified ConvertGrammar as Cnv import qualified ConvertGrammar as Cnv
import qualified PrintParser as Prt import qualified PrintParser as Prt
import GFC
import qualified MkGFC as MC
import PrintCFGrammar (prCanonAsCFGM)
import MyParser import MyParser
import MoreCustom -- either small/ or big/. The one in Small is empty. import MoreCustom -- either small/ or big/. The one in Small is empty.
@@ -55,6 +59,23 @@ import UseIO
import Monad import Monad
-- character codings
import Unicode
import UTF8 (decodeUTF8)
import Greek (mkGreek)
import Arabic (mkArabic)
import Hebrew (mkHebrew)
import Russian (mkRussian, mkRusKOI8)
import Ethiopic (mkEthiopic)
import Tamil (mkTamil)
import OCSCyrillic (mkOCSCyrillic)
import LatinASupplement (mkLatinASupplement)
import Devanagari (mkDevanagari)
import Hiragana (mkJapanese)
import ExtendedArabic (mkArabic0600)
import ExtendedArabic (mkExtendedArabic)
import ExtraDiacritics (mkExtraDiacritics)
-- minimal version also used in Hugs. AR 2/12/2002. -- minimal version also used in Hugs. AR 2/12/2002.
-- databases for customizable commands. AR 21/11/2001 -- databases for customizable commands. AR 21/11/2001
@@ -76,6 +97,9 @@ customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar)
-- grammarPrinter, "-printer=x" -- grammarPrinter, "-printer=x"
customGrammarPrinter :: CustomData (StateGrammar -> String) customGrammarPrinter :: CustomData (StateGrammar -> String)
-- multiGrammarPrinter, "-printer=x"
customMultiGrammarPrinter :: CustomData (CanonGrammar -> String)
-- syntaxPrinter, "-printer=x" -- syntaxPrinter, "-printer=x"
customSyntaxPrinter :: CustomData (GF.Grammar -> String) customSyntaxPrinter :: CustomData (GF.Grammar -> String)
@@ -100,6 +124,10 @@ customTokenizer :: CustomData (StateGrammar -> String -> [CFTok])
-- useUntokenizer, "-unlexer=x" --- should be from token list to string -- useUntokenizer, "-unlexer=x" --- should be from token list to string
customUntokenizer :: CustomData (StateGrammar -> String -> String) customUntokenizer :: CustomData (StateGrammar -> String -> String)
-- uniCoding, "-coding=x"
-- contains conversions from different codings to the internal
-- unicode coding
customUniCoding :: CustomData (String -> String)
-- this is the way of selecting an item -- this is the way of selecting an item
customOrDefault :: Options -> OptFun -> CustomData a -> a customOrDefault :: Options -> OptFun -> CustomData a -> a
@@ -185,6 +213,15 @@ customGrammarPrinter =
] ]
++ moreCustomGrammarPrinter ++ moreCustomGrammarPrinter
customMultiGrammarPrinter =
customData "Printers for multiple grammars, selected by option -printer=x" $
[
(strCI "gfcm", MC.prCanon)
,(strCI "cfgm", prCanonAsCFGM)
]
++ moreCustomMultiGrammarPrinter
customSyntaxPrinter = customSyntaxPrinter =
customData "Syntax printers, selected by option -printer=x" $ customData "Syntax printers, selected by option -printer=x" $
[ [
@@ -308,3 +345,25 @@ customUntokenizer =
-- add your own untokenizers here -- add your own untokenizers here
] ]
++ moreCustomUntokenizer ++ moreCustomUntokenizer
customUniCoding =
customData "Alphabet codings, selected by option -coding=x" $
[
(strCI "latin1", id) -- DEFAULT
,(strCI "utf8", decodeUTF8)
,(strCI "greek", treat [] mkGreek)
,(strCI "hebrew", mkHebrew)
,(strCI "arabic", mkArabic)
,(strCI "russian", treat [] mkRussian)
,(strCI "russianKOI8", mkRusKOI8)
,(strCI "ethiopic", mkEthiopic)
,(strCI "tamil", mkTamil)
,(strCI "OCScyrillic", mkOCSCyrillic)
,(strCI "devanagari", mkDevanagari)
,(strCI "latinasupplement", mkLatinASupplement)
,(strCI "japanese", mkJapanese)
,(strCI "arabic0600", mkArabic0600)
,(strCI "extendedarabic", mkExtendedArabic)
,(strCI "extradiacritics", mkExtraDiacritics)
]
++ moreCustomUniCoding

2
src/GF/UseGrammar/MoreCustom.hs
View File

@@ -5,6 +5,7 @@ module MoreCustom where
moreCustomGrammarParser = [] moreCustomGrammarParser = []
moreCustomGrammarPrinter = [] moreCustomGrammarPrinter = []
moreCustomMultiGrammarPrinter = []
moreCustomSyntaxPrinter = [] moreCustomSyntaxPrinter = []
moreCustomTermPrinter = [] moreCustomTermPrinter = []
moreCustomTermCommand = [] moreCustomTermCommand = []
@@ -13,3 +14,4 @@ moreCustomStringCommand = []
moreCustomParser = [] moreCustomParser = []
moreCustomTokenizer = [] moreCustomTokenizer = []
moreCustomUntokenizer = [] moreCustomUntokenizer = []
moreCustomUniCoding = []

6
src/GF/UseGrammar/RealMoreCustom.hs
View File

@@ -70,6 +70,8 @@ moreCustomGrammarPrinter =
--- also include printing via grammar2syntax! --- also include printing via grammar2syntax!
] ]
moreCustomMultiGrammarPrinter = []
moreCustomSyntaxPrinter = moreCustomSyntaxPrinter =
[ [
(strCIm "gf", S.prSyntax) -- DEFAULT (strCIm "gf", S.prSyntax) -- DEFAULT
@@ -118,5 +120,9 @@ moreCustomUntokenizer =
-- add your own untokenizers here -- add your own untokenizers here
] ]
moreCustomUniCoding =
[
-- add your own codings here
]
strCIm = id strCIm = id

2
src/Makefile
View File

@@ -8,7 +8,7 @@ GHCFUDFLAG=-package Fudgets
JAVAFLAGS=-target 1.4 -source 1.4 JAVAFLAGS=-target 1.4 -source 1.4
HUGSINCLUDE =.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile:newparsing:trace: HUGSINCLUDE =.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile:newparsing:trace:
BASICINCLUDE =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -inotrace BASICINCLUDE =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -inotrace -icfgm
GHCINCLUDE =-ifor-ghc $(BASICINCLUDE) GHCINCLUDE =-ifor-ghc $(BASICINCLUDE)
GHCINCLUDENOFUD=-ifor-ghc-nofud $(BASICINCLUDE) GHCINCLUDENOFUD=-ifor-ghc-nofud $(BASICINCLUDE)
GHCINCLUDEGFT =-ifor-gft $(BASICINCLUDE) GHCINCLUDEGFT =-ifor-gft $(BASICINCLUDE)