mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Added CFGM format (pm -printer=cfgm) and utf8 conversion for pm.
This commit is contained in:
bringert
@@ -33,6 +33,7 @@ import ShellState
|
||||
import Linear
|
||||
import GFC
|
||||
import qualified Grammar as G
|
||||
import Modules
|
||||
import PrGrammar
|
||||
import qualified Compute as Co
|
||||
import qualified Ident as I
|
||||
@@ -284,13 +285,22 @@ prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts)
|
||||
optPrintGrammar :: Options -> StateGrammar -> String
|
||||
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 opts = customOrDefault opts grammarPrinter customSyntaxPrinter
|
||||
|
||||
prCanonGrammar :: CanonGrammar -> String
|
||||
prCanonGrammar = MC.prCanon
|
||||
|
||||
|
||||
optPrintTree :: Options -> GFGrammar -> Tree -> String
|
||||
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
|
||||
|
||||
-- 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
|
||||
|
||||
50
src/GF/CFGM/AbsCFG.hs
Normal file
50
src/GF/CFGM/AbsCFG.hs
Normal 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
35
src/GF/CFGM/CFG.cf
Normal 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
273
src/GF/CFGM/LexCFG.hs
Normal 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
129
src/GF/CFGM/LexCFG.x
Normal 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
766
src/GF/CFGM/ParCFG.hs
Normal 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
144
src/GF/CFGM/ParCFG.y
Normal 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
164
src/GF/CFGM/PrintCFG.hs
Normal 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
33
src/GF/CFGM/PrintCFGrammar.hs
Normal 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"
|
||||
|
||||
@@ -178,3 +178,56 @@ wordsInTerm trm = filter (not . null) $ case trm of
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
@@ -47,3 +47,70 @@ prCanonModInfo = printTree . info2mod
|
||||
prGrammar :: CanonGrammar -> String
|
||||
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]
|
||||
@@ -69,12 +69,13 @@ instance Print Double where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = doc (showChar '\'' . mkEsc s . showChar '\'')
|
||||
prtList s = doc (showChar '"' . concatS (map mkEsc s) . showChar '"')
|
||||
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
|
||||
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
|
||||
|
||||
mkEsc :: Char -> ShowS
|
||||
mkEsc s = case s of
|
||||
_ | elem s "\\\"'" -> showChar '\\' . showChar s
|
||||
mkEsc :: Char -> Char -> ShowS
|
||||
mkEsc q s = case s of
|
||||
_ | s == q -> showChar '\\' . showChar s
|
||||
'\\'-> showString "\\\\"
|
||||
'\n' -> showString "\\n"
|
||||
'\t' -> showString "\\t"
|
||||
_ -> showChar s
|
||||
|
||||
@@ -15,7 +15,10 @@ infixl 9 !?
|
||||
|
||||
ifNull :: b -> ([a] -> b) -> [a] -> b
|
||||
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
|
||||
|
||||
data Err a = Ok a | Bad String -- like Maybe type with error msgs
|
||||
|
||||
@@ -75,6 +75,12 @@ addOpenQualif i j (Module mt ms fs me ops js) =
|
||||
allFlags :: MGrammar i f a -> [f]
|
||||
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 {
|
||||
mainAbstract :: i ,
|
||||
mainConcretes :: [MainConcreteSpec i]
|
||||
|
||||
@@ -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
|
||||
CPrintMultiGrammar -> do
|
||||
sa' <- changeState purgeShellState sa
|
||||
returnArg (AString (prCanonGrammar (canModules st))) sa'
|
||||
returnArg (AString (optPrintMultiGrammar opts cgr)) sa'
|
||||
|
||||
---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa
|
||||
---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa
|
||||
|
||||
@@ -162,7 +162,7 @@ optionsOfCommand co = case co of
|
||||
CSystemCommand _ -> none
|
||||
|
||||
CPrintGrammar -> both "utf8" "printer lang"
|
||||
CPrintMultiGrammar -> opts "utf8"
|
||||
CPrintMultiGrammar -> both "utf8" "printer"
|
||||
|
||||
CHelp _ -> opts "all"
|
||||
|
||||
|
||||
@@ -66,12 +66,13 @@ instance Print Double where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = doc (showChar '\'' . mkEsc s . showChar '\'')
|
||||
prtList s = doc (showChar '"' . concatS (map mkEsc s) . showChar '"')
|
||||
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
|
||||
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
|
||||
|
||||
mkEsc :: Char -> ShowS
|
||||
mkEsc s = case s of
|
||||
_ | elem s "\\\"" -> showChar '\\' . showChar s -- H (don't escape ')
|
||||
mkEsc :: Char -> Char -> ShowS
|
||||
mkEsc q s = case s of
|
||||
_ | s == q -> showChar '\\' . showChar s
|
||||
'\\'-> showString "\\\\"
|
||||
'\n' -> showString "\\n"
|
||||
'\t' -> showString "\\t"
|
||||
_ -> showChar s
|
||||
|
||||
@@ -44,8 +44,9 @@ mkUnicode s = case s of
|
||||
c:cs -> remClosing (c:u) cs
|
||||
_ -> (reverse u,[]) -- forgiving missing end
|
||||
|
||||
-- don't convert XML tags --- assumes <> always means XML tags
|
||||
treat old mk s = case s of
|
||||
-- don't convert XML tags --- assumes <> always means XML tags
|
||||
treat :: String -> (String -> String) -> String -> String
|
||||
treat old mk s = case s of
|
||||
'<':cs -> mk (reverse old) ++ '<':noTreat cs
|
||||
c:cs -> treat (c:old) mk cs
|
||||
_ -> mk (reverse old)
|
||||
|
||||
@@ -47,6 +47,10 @@ import qualified ParseCF as PCF
|
||||
import qualified ConvertGrammar as Cnv
|
||||
import qualified PrintParser as Prt
|
||||
|
||||
import GFC
|
||||
import qualified MkGFC as MC
|
||||
import PrintCFGrammar (prCanonAsCFGM)
|
||||
|
||||
import MyParser
|
||||
|
||||
import MoreCustom -- either small/ or big/. The one in Small is empty.
|
||||
@@ -55,6 +59,23 @@ import UseIO
|
||||
|
||||
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.
|
||||
|
||||
-- databases for customizable commands. AR 21/11/2001
|
||||
@@ -76,6 +97,9 @@ customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar)
|
||||
-- grammarPrinter, "-printer=x"
|
||||
customGrammarPrinter :: CustomData (StateGrammar -> String)
|
||||
|
||||
-- multiGrammarPrinter, "-printer=x"
|
||||
customMultiGrammarPrinter :: CustomData (CanonGrammar -> String)
|
||||
|
||||
-- syntaxPrinter, "-printer=x"
|
||||
customSyntaxPrinter :: CustomData (GF.Grammar -> String)
|
||||
|
||||
@@ -100,6 +124,10 @@ customTokenizer :: CustomData (StateGrammar -> String -> [CFTok])
|
||||
-- useUntokenizer, "-unlexer=x" --- should be from token list to 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
|
||||
customOrDefault :: Options -> OptFun -> CustomData a -> a
|
||||
@@ -185,6 +213,15 @@ customGrammarPrinter =
|
||||
]
|
||||
++ moreCustomGrammarPrinter
|
||||
|
||||
customMultiGrammarPrinter =
|
||||
customData "Printers for multiple grammars, selected by option -printer=x" $
|
||||
[
|
||||
(strCI "gfcm", MC.prCanon)
|
||||
,(strCI "cfgm", prCanonAsCFGM)
|
||||
]
|
||||
++ moreCustomMultiGrammarPrinter
|
||||
|
||||
|
||||
customSyntaxPrinter =
|
||||
customData "Syntax printers, selected by option -printer=x" $
|
||||
[
|
||||
@@ -308,3 +345,25 @@ customUntokenizer =
|
||||
-- add your own untokenizers here
|
||||
]
|
||||
++ 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
|
||||
|
||||
@@ -5,6 +5,7 @@ module MoreCustom where
|
||||
|
||||
moreCustomGrammarParser = []
|
||||
moreCustomGrammarPrinter = []
|
||||
moreCustomMultiGrammarPrinter = []
|
||||
moreCustomSyntaxPrinter = []
|
||||
moreCustomTermPrinter = []
|
||||
moreCustomTermCommand = []
|
||||
@@ -13,3 +14,4 @@ moreCustomStringCommand = []
|
||||
moreCustomParser = []
|
||||
moreCustomTokenizer = []
|
||||
moreCustomUntokenizer = []
|
||||
moreCustomUniCoding = []
|
||||
|
||||
@@ -70,6 +70,8 @@ moreCustomGrammarPrinter =
|
||||
--- also include printing via grammar2syntax!
|
||||
]
|
||||
|
||||
moreCustomMultiGrammarPrinter = []
|
||||
|
||||
moreCustomSyntaxPrinter =
|
||||
[
|
||||
(strCIm "gf", S.prSyntax) -- DEFAULT
|
||||
@@ -118,5 +120,9 @@ moreCustomUntokenizer =
|
||||
-- add your own untokenizers here
|
||||
]
|
||||
|
||||
moreCustomUniCoding =
|
||||
[
|
||||
-- add your own codings here
|
||||
]
|
||||
|
||||
strCIm = id
|
||||
|
||||
@@ -8,7 +8,7 @@ GHCFUDFLAG=-package Fudgets
|
||||
JAVAFLAGS=-target 1.4 -source 1.4
|
||||
|
||||
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)
|
||||
GHCINCLUDENOFUD=-ifor-ghc-nofud $(BASICINCLUDE)
|
||||
GHCINCLUDEGFT =-ifor-gft $(BASICINCLUDE)
|
||||
|
||||
Reference in New Issue
Block a user