removed Canon/GFCC
This commit is contained in:
aarne committed
1 parent
1b4f7c9741
commit
2905d5552c
21 files changed
-2755
No files matched your search
@@ -1,70 +0,0 @@
|
||||
module GF.Canon.GFCC.AbsGFCC where
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
newtype CId = CId String deriving (Eq,Ord,Show)
|
||||
data Grammar =
|
||||
Grm Header Abstract [Concrete]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Header =
|
||||
Hdr CId [CId]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Abstract =
|
||||
Abs [AbsDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Concrete =
|
||||
Cnc CId [CncDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data AbsDef =
|
||||
Fun CId Type Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data CncDef =
|
||||
Lin CId Term
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Type =
|
||||
Typ [CId] CId
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Exp =
|
||||
Tr Atom [Exp]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Atom =
|
||||
AC CId
|
||||
| AS String
|
||||
| AI Integer
|
||||
| AF Double
|
||||
| AM
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Term =
|
||||
R [Term]
|
||||
| P Term Term
|
||||
| S [Term]
|
||||
| K Tokn
|
||||
| V Int
|
||||
| C Int
|
||||
| F CId
|
||||
| FV [Term]
|
||||
| W String Term
|
||||
| RP Term Term
|
||||
| TM
|
||||
| L CId Term
|
||||
| BV CId
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Tokn =
|
||||
KS String
|
||||
| KP [String] [Variant]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Variant =
|
||||
Var [String] [String]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
@@ -1,170 +0,0 @@
|
||||
module GF.Canon.GFCC.CheckGFCC where
|
||||
|
||||
import GF.Canon.GFCC.DataGFCC
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
import GF.Canon.GFCC.PrintGFCC
|
||||
import GF.Canon.GFCC.ErrM
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad
|
||||
|
||||
andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
||||
andMapM f xs = mapM f xs >>= return . and
|
||||
|
||||
labelBoolIO :: String -> IO (x,Bool) -> IO (x,Bool)
|
||||
labelBoolIO msg iob = do
|
||||
(x,b) <- iob
|
||||
if b then return (x,b) else (putStrLn msg >> return (x,b))
|
||||
|
||||
checkGFCC :: GFCC -> IO (GFCC,Bool)
|
||||
checkGFCC gfcc = do
|
||||
(cs,bs) <- mapM (checkConcrete gfcc)
|
||||
(Map.assocs (concretes gfcc)) >>= return . unzip
|
||||
return (gfcc {concretes = Map.fromAscList cs}, and bs)
|
||||
|
||||
checkConcrete :: GFCC -> (CId,Concr) -> IO ((CId,Concr),Bool)
|
||||
checkConcrete gfcc (lang,cnc) =
|
||||
labelBoolIO ("happened in language " ++ printTree lang) $ do
|
||||
(rs,bs) <- mapM checkl (Map.assocs cnc) >>= return . unzip
|
||||
return ((lang,Map.fromAscList rs),and bs)
|
||||
where
|
||||
checkl r@(CId f,_) = case head f of
|
||||
'_' -> return (r,True)
|
||||
_ -> checkLin gfcc lang r
|
||||
|
||||
checkLin :: GFCC -> CId -> (CId,Term) -> IO ((CId,Term),Bool)
|
||||
checkLin gfcc lang (f,t) =
|
||||
labelBoolIO ("happened in function " ++ printTree f) $ do
|
||||
(t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t
|
||||
return ((f,t'),b)
|
||||
|
||||
inferTerm :: [Tpe] -> Term -> Err (Term,Tpe)
|
||||
inferTerm args trm = case trm of
|
||||
K _ -> returnt str
|
||||
C i -> returnt $ ints i
|
||||
V i -> do
|
||||
testErr (i < length args) ("too large index " ++ show i)
|
||||
returnt $ args !! i
|
||||
S ts -> do
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
let tys' = filter (/=str) tys
|
||||
testErr (null tys')
|
||||
("expected Str in " ++ prt trm ++ " not " ++ unwords (map prt tys'))
|
||||
return (S ts',str)
|
||||
R ts -> do
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
return $ (R ts',tuple tys)
|
||||
P t u -> do
|
||||
(t',tt) <- infer t
|
||||
(u',tu) <- infer u
|
||||
case tt of
|
||||
R tys -> case tu of
|
||||
R vs -> infer $ foldl P t' [P u' (C i) | i <- [0 .. length vs - 1]]
|
||||
--- R [v] -> infer $ P t v
|
||||
--- R (v:vs) -> infer $ P (head tys) (R vs)
|
||||
|
||||
C i -> do
|
||||
testErr (i < length tys)
|
||||
("required more than " ++ show i ++ " fields in " ++ prt (R tys))
|
||||
return (P t' u', tys !! i) -- record: index must be known
|
||||
_ -> do
|
||||
let typ = head tys
|
||||
testErr (all (==typ) tys) ("different types in table " ++ prt trm)
|
||||
return (P t' u', typ) -- table: types must be same
|
||||
_ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt
|
||||
FV [] -> returnt str ----
|
||||
FV (t:ts) -> do
|
||||
(t',ty) <- infer t
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
testErr (all (==ty) tys) ("different types in variants " ++ prt trm)
|
||||
return (FV (t':ts'),ty)
|
||||
W s r -> infer r
|
||||
_ -> Bad ("no type inference for " ++ prt trm)
|
||||
where
|
||||
returnt ty = return (trm,ty)
|
||||
infer = inferTerm args
|
||||
prt = printTree
|
||||
|
||||
checkTerm :: LinType -> Term -> IO (Term,Bool)
|
||||
checkTerm (args,val) trm = case inferTerm args trm of
|
||||
Ok (t,ty) -> if eqType ty val
|
||||
then return (t,True)
|
||||
else do
|
||||
putStrLn $ "term: " ++ printTree trm ++
|
||||
"\nexpected type: " ++ printTree val ++
|
||||
"\ninferred type: " ++ printTree ty
|
||||
return (t,False)
|
||||
Bad s -> do
|
||||
putStrLn s
|
||||
return (trm,False)
|
||||
|
||||
eqType :: Tpe -> Tpe -> Bool
|
||||
eqType inf exp = case (inf,exp) of
|
||||
(C k, C n) -> k <= n -- only run-time corr.
|
||||
(R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts]
|
||||
_ -> inf == exp
|
||||
|
||||
-- should be in a generic module, but not in the run-time DataGFCC
|
||||
|
||||
type Tpe = Term
|
||||
type LinType = ([Tpe],Tpe)
|
||||
|
||||
tuple :: [Tpe] -> Tpe
|
||||
tuple = R
|
||||
|
||||
ints :: Int -> Tpe
|
||||
ints = C
|
||||
|
||||
str :: Tpe
|
||||
str = S []
|
||||
|
||||
lintype :: GFCC -> CId -> CId -> LinType
|
||||
lintype gfcc lang fun = case lookType gfcc fun of
|
||||
Typ cs c -> (map linc cs, linc c)
|
||||
where
|
||||
linc = lookLincat gfcc lang
|
||||
|
||||
lookLincat :: GFCC -> CId -> CId -> Term
|
||||
lookLincat gfcc lang (CId cat) = lookLin gfcc lang (CId ("__" ++ cat))
|
||||
|
||||
linRules :: Map.Map CId Term -> [(CId,Term)]
|
||||
linRules cnc = [(f,t) | (f@(CId (c:_)),t) <- Map.assocs cnc, c /= '_'] ----
|
||||
|
||||
inline :: GFCC -> CId -> Term -> Term
|
||||
inline gfcc lang t = case t of
|
||||
F c -> inl $ look c
|
||||
_ -> composSafeOp inl t
|
||||
where
|
||||
inl = inline gfcc lang
|
||||
look = lookLin gfcc lang
|
||||
|
||||
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
|
||||
composOp f trm = case trm of
|
||||
R ts -> liftM R $ mapM f ts
|
||||
S ts -> liftM S $ mapM f ts
|
||||
FV ts -> liftM FV $ mapM f ts
|
||||
P t u -> liftM2 P (f t) (f u)
|
||||
W s t -> liftM (W s) $ f t
|
||||
_ -> return trm
|
||||
|
||||
composSafeOp :: (Term -> Term) -> Term -> Term
|
||||
composSafeOp f = maybe undefined id . composOp (return . f)
|
||||
|
||||
-- from GF.Data.Oper
|
||||
|
||||
maybeErr :: String -> Maybe a -> Err a
|
||||
maybeErr s = maybe (Bad s) Ok
|
||||
|
||||
testErr :: Bool -> String -> Err ()
|
||||
testErr cond msg = if cond then return () else Bad msg
|
||||
|
||||
errVal :: a -> Err a -> a
|
||||
errVal a = err (const a) id
|
||||
|
||||
errIn :: String -> Err a -> Err a
|
||||
errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return
|
||||
|
||||
err :: (String -> b) -> (a -> b) -> Err a -> b
|
||||
err d f e = case e of
|
||||
Ok a -> f a
|
||||
Bad s -> d s
|
||||
@@ -1,148 +0,0 @@
|
||||
module GF.Canon.GFCC.DataGFCC where
|
||||
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
import GF.Canon.GFCC.PrintGFCC
|
||||
import Data.Map
|
||||
import Data.List
|
||||
import Debug.Trace ----
|
||||
|
||||
data GFCC = GFCC {
|
||||
absname :: CId ,
|
||||
cncnames :: [CId] ,
|
||||
abstract :: Abstr ,
|
||||
concretes :: Map CId Concr
|
||||
}
|
||||
|
||||
-- redundant double representation for fast lookup
|
||||
data Abstr = Abstr {
|
||||
funs :: Map CId Type, -- find the type of a fun
|
||||
cats :: Map CId [CId] -- find the funs giving a cat
|
||||
}
|
||||
|
||||
statGFCC :: GFCC -> String
|
||||
statGFCC gfcc = unlines [
|
||||
"Abstract\t" ++ pr (absname gfcc),
|
||||
"Concretes\t" ++ unwords (Prelude.map pr (cncnames gfcc)),
|
||||
"Categories\t" ++ unwords (Prelude.map pr (keys (cats (abstract gfcc))))
|
||||
]
|
||||
where pr (CId s) = s
|
||||
|
||||
type Concr = Map CId Term
|
||||
|
||||
lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a
|
||||
lookMap d c m = maybe d id $ Data.Map.lookup c m
|
||||
|
||||
lookLin :: GFCC -> CId -> CId -> Term
|
||||
lookLin mcfg lang fun =
|
||||
lookMap TM fun $ lookMap undefined lang $ concretes mcfg
|
||||
|
||||
-- | Look up the type of a function.
|
||||
lookType :: GFCC -> CId -> Type
|
||||
lookType gfcc f = lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc))
|
||||
|
||||
linearize :: GFCC -> CId -> Exp -> String
|
||||
linearize mcfg lang = realize . linExp mcfg lang
|
||||
|
||||
realize :: Term -> String
|
||||
realize trm = case trm of
|
||||
R ts -> realize (ts !! 0)
|
||||
S ss -> unwords $ Prelude.map realize ss
|
||||
K t -> case t of
|
||||
KS s -> s
|
||||
KP s _ -> unwords s ---- prefix choice TODO
|
||||
W s t -> s ++ realize t
|
||||
FV ts -> realize (ts !! 0) ---- other variants TODO
|
||||
RP _ r -> realize r
|
||||
TM -> "?"
|
||||
_ -> "ERROR " ++ show trm ---- debug
|
||||
|
||||
linExp :: GFCC -> CId -> Exp -> Term
|
||||
linExp mcfg lang tree@(Tr at trees) =
|
||||
case at of
|
||||
AC fun -> comp (Prelude.map lin trees) $ look fun
|
||||
AS s -> R [kks (show s)] -- quoted
|
||||
AI i -> R [kks (show i)]
|
||||
AF d -> R [kks (show d)]
|
||||
AM -> TM
|
||||
where
|
||||
lin = linExp mcfg lang
|
||||
comp = compute mcfg lang
|
||||
look = lookLin mcfg lang
|
||||
|
||||
exp0 :: Exp
|
||||
exp0 = Tr (AS "NO_PARSE") []
|
||||
|
||||
term0 :: CId -> Term
|
||||
term0 (CId s) = R [kks ("#" ++ s ++ "#")]
|
||||
|
||||
kks :: String -> Term
|
||||
kks = K . KS
|
||||
|
||||
compute :: GFCC -> CId -> [Term] -> Term -> Term
|
||||
compute mcfg lang args = comp where
|
||||
comp trm = case trm of
|
||||
P r p -> proj (comp r) (comp p)
|
||||
RP i t -> RP (comp i) (comp t)
|
||||
W s t -> W s (comp t)
|
||||
R ts -> R $ Prelude.map comp ts
|
||||
V i -> idx args i -- already computed
|
||||
F c -> comp $ look c -- not computed (if contains argvar)
|
||||
FV ts -> FV $ Prelude.map comp ts
|
||||
S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts
|
||||
_ -> trm
|
||||
|
||||
look = lookLin mcfg lang
|
||||
|
||||
idx xs i = if i > length xs - 1
|
||||
then trace
|
||||
("too large " ++ show i ++ " for\n" ++ unlines (Prelude.map prt xs) ++ "\n") TM
|
||||
else xs !! i
|
||||
|
||||
proj r p = case (r,p) of
|
||||
(_, FV ts) -> FV $ Prelude.map (proj r) ts
|
||||
(FV ts, _ ) -> FV $ Prelude.map (\t -> proj t r) ts
|
||||
(W s t, _) -> kks (s ++ getString (proj t p))
|
||||
(_,R is) -> trace ("projection " ++ show p ++ "\n") $ comp $ foldl P r is
|
||||
_ -> comp $ getField r (getIndex p)
|
||||
|
||||
getString t = case t of
|
||||
K (KS s) -> s
|
||||
_ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR"
|
||||
|
||||
getIndex t = case t of
|
||||
C i -> i
|
||||
RP p _ -> getIndex p
|
||||
TM -> 0 -- default value for parameter
|
||||
_ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0
|
||||
|
||||
getField t i = case t of
|
||||
R rs -> idx rs i
|
||||
RP _ r -> getField r i
|
||||
TM -> TM
|
||||
_ -> trace ("ERROR in grammar compiler: field from " ++ show t) t
|
||||
|
||||
prt = printTree
|
||||
|
||||
mkGFCC :: Grammar -> GFCC
|
||||
mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
|
||||
absname = a,
|
||||
cncnames = cs,
|
||||
abstract =
|
||||
let
|
||||
fs = fromAscList [(fun,typ) | Fun fun typ _ <- funs]
|
||||
cats = sort $ nub [c | Fun f (Typ _ c) _ <- funs]
|
||||
cs = fromAscList
|
||||
[(cat,[f | Fun f (Typ _ c) _ <- funs, c==cat]) | cat <- cats]
|
||||
in Abstr fs cs,
|
||||
concretes = fromAscList [(lang, mkCnc lins) | Cnc lang lins <- ccs]
|
||||
}
|
||||
where
|
||||
mkCnc lins = fromList [(fun,lin) | Lin fun lin <- lins] ---- Asc
|
||||
|
||||
printGFCC :: GFCC -> String
|
||||
printGFCC gfcc = printTree $ Grm
|
||||
(Hdr (absname gfcc) (cncnames gfcc))
|
||||
(Abs [Fun f ty (Tr (AC f) []) | (f,ty) <- assocs (funs (abstract gfcc))])
|
||||
[Cnc lang [Lin f t | (f,t) <- assocs lins] |
|
||||
(lang,lins) <- assocs (concretes gfcc)]
|
||||
|
||||
@@ -1,16 +0,0 @@
|
||||
-- BNF Converter: Error Monad
|
||||
-- Copyright (C) 2004 Author: Aarne Ranta
|
||||
|
||||
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
|
||||
module GF.Canon.GFCC.ErrM where
|
||||
|
||||
-- the Error monad: like Maybe type with error msgs
|
||||
|
||||
data Err a = Ok a | Bad String
|
||||
deriving (Read, Show, Eq)
|
||||
|
||||
instance Monad Err where
|
||||
return = Ok
|
||||
fail = Bad
|
||||
Ok a >>= f = f a
|
||||
Bad s >>= f = Bad s
|
||||
@@ -1,127 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GFCCAPI
|
||||
-- Maintainer : Aarne Ranta
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date:
|
||||
-- > CVS $Author:
|
||||
-- > CVS $Revision:
|
||||
--
|
||||
-- Reduced Application Programmer's Interface to GF, meant for
|
||||
-- embedded GF systems. AR 19/9/2007
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Canon.GFCC.GFCCAPI where
|
||||
|
||||
import GF.Canon.GFCC.DataGFCC
|
||||
--import GF.Canon.GFCC.GenGFCC
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
import GF.Canon.GFCC.ParGFCC
|
||||
import GF.Canon.GFCC.PrintGFCC
|
||||
import GF.Canon.GFCC.ErrM
|
||||
import GF.Parsing.FCFG
|
||||
import qualified GF.Canon.GFCC.GenGFCC as G
|
||||
import GF.Conversion.SimpleToFCFG (convertGrammar,FCat(..))
|
||||
|
||||
--import GF.Data.Operations
|
||||
--import GF.Infra.UseIO
|
||||
import qualified Data.Map as Map
|
||||
import System.Random (newStdGen)
|
||||
import System.Directory (doesFileExist)
|
||||
|
||||
|
||||
-- This API is meant to be used when embedding GF grammars in Haskell
|
||||
-- programs. The embedded system is supposed to use the
|
||||
-- .gfcm grammar format, which is first produced by the gf program.
|
||||
|
||||
---------------------------------------------------
|
||||
-- Interface
|
||||
---------------------------------------------------
|
||||
|
||||
data MultiGrammar = MultiGrammar {gfcc :: GFCC, parsers :: [(Language,FCFPInfo)]}
|
||||
type Language = String
|
||||
type Category = String
|
||||
type Tree = Exp
|
||||
|
||||
file2grammar :: FilePath -> IO MultiGrammar
|
||||
|
||||
linearize :: MultiGrammar -> Language -> Tree -> String
|
||||
parse :: MultiGrammar -> Language -> Category -> String -> [Tree]
|
||||
|
||||
linearizeAll :: MultiGrammar -> Tree -> [String]
|
||||
linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)]
|
||||
|
||||
parseAll :: MultiGrammar -> Category -> String -> [[Tree]]
|
||||
parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])]
|
||||
|
||||
generateAll :: MultiGrammar -> Category -> [Tree]
|
||||
generateRandom :: MultiGrammar -> Category -> IO [Tree]
|
||||
|
||||
readTree :: MultiGrammar -> String -> Tree
|
||||
showTree :: Tree -> String
|
||||
|
||||
languages :: MultiGrammar -> [Language]
|
||||
categories :: MultiGrammar -> [Category]
|
||||
|
||||
startCat :: MultiGrammar -> Category
|
||||
|
||||
---------------------------------------------------
|
||||
-- Implementation
|
||||
---------------------------------------------------
|
||||
|
||||
file2grammar f = do
|
||||
gfcc <- file2gfcc f
|
||||
let fcfgs = convertGrammar gfcc
|
||||
return (MultiGrammar gfcc [(lang, buildFCFPInfo fcfg) | (CId lang,fcfg) <- fcfgs])
|
||||
|
||||
file2gfcc f =
|
||||
readFileIf f >>= err (error "no parse") (return . mkGFCC) . pGrammar . myLexer
|
||||
|
||||
linearize mgr lang = GF.Canon.GFCC.DataGFCC.linearize (gfcc mgr) (CId lang)
|
||||
|
||||
parse mgr lang cat s =
|
||||
case lookup lang (parsers mgr) of
|
||||
Nothing -> error "no parser"
|
||||
Just pinfo -> case parseFCF "bottomup" pinfo (CId cat) (words s) of
|
||||
Ok x -> x
|
||||
Bad s -> error s
|
||||
|
||||
linearizeAll mgr = map snd . linearizeAllLang mgr
|
||||
linearizeAllLang mgr t =
|
||||
[(lang,linearThis mgr lang t) | lang <- languages mgr]
|
||||
|
||||
parseAll mgr cat = map snd . parseAllLang mgr cat
|
||||
|
||||
parseAllLang mgr cat s =
|
||||
[(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)]
|
||||
|
||||
generateRandom mgr cat = do
|
||||
gen <- newStdGen
|
||||
return $ G.generateRandom gen (gfcc mgr) (CId cat)
|
||||
|
||||
generateAll mgr cat = G.generate (gfcc mgr) (CId cat)
|
||||
|
||||
readTree _ = err (const exp0) id . (pExp . myLexer)
|
||||
|
||||
showTree t = printTree t
|
||||
|
||||
languages mgr = [l | CId l <- cncnames (gfcc mgr)]
|
||||
|
||||
categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))]
|
||||
|
||||
startCat mgr = "S" ----
|
||||
|
||||
------------ for internal use only
|
||||
|
||||
linearThis = GF.Canon.GFCC.GFCCAPI.linearize
|
||||
|
||||
err f g ex = case ex of
|
||||
Ok x -> g x
|
||||
Bad s -> f s
|
||||
|
||||
readFileIf f = do
|
||||
b <- doesFileExist f
|
||||
if b then readFile f
|
||||
else putStrLn ("file " ++ f ++ " not found") >> return ""
|
||||
@@ -1,212 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GrammarToHaskell
|
||||
-- Maintainer : Aarne Ranta
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/17 12:39:07 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- to write a GF abstract grammar into a Haskell module with translations from
|
||||
-- data objects into GF trees. Example: GSyntax for Agda.
|
||||
-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Canon.GFCC.GFCCToHaskell (grammar2haskell, grammar2haskellGADT) where
|
||||
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
import GF.Canon.GFCC.DataGFCC
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.List --(isPrefixOf, find, intersperse)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- | the main function
|
||||
grammar2haskell :: GFCC -> String
|
||||
grammar2haskell gr = foldr (++++) [] $
|
||||
haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
|
||||
where gr' = hSkeleton gr
|
||||
|
||||
grammar2haskellGADT :: GFCC -> String
|
||||
grammar2haskellGADT gr = foldr (++++) [] $
|
||||
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++
|
||||
haskPreamble ++ [datatypesGADT gr', gfinstances gr', fginstances gr']
|
||||
where gr' = hSkeleton gr
|
||||
|
||||
-- | by this you can prefix all identifiers with stg; the default is 'G'
|
||||
gId :: OIdent -> OIdent
|
||||
gId i = 'G':i
|
||||
|
||||
haskPreamble =
|
||||
[
|
||||
"module GSyntax where",
|
||||
"",
|
||||
"import GF.Canon.GFCC.AbsGFCC",
|
||||
"import GF.Canon.GFCC.DataGFCC",
|
||||
"import GF.Data.Operations",
|
||||
"----------------------------------------------------",
|
||||
"-- automatic translation from GF to Haskell",
|
||||
"----------------------------------------------------",
|
||||
"",
|
||||
"class Gf a where gf :: a -> Exp",
|
||||
"class Fg a where fg :: Exp -> a",
|
||||
"",
|
||||
predefInst "GString" "String" "Tr (AS s) []",
|
||||
"",
|
||||
predefInst "GInt" "Integer" "Tr (AI s) []",
|
||||
"",
|
||||
predefInst "GFloat" "Double" "Tr (AF s) []",
|
||||
"",
|
||||
"----------------------------------------------------",
|
||||
"-- below this line machine-generated",
|
||||
"----------------------------------------------------",
|
||||
""
|
||||
]
|
||||
|
||||
predefInst gtyp typ patt =
|
||||
"newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
|
||||
"instance Gf" +++ gtyp +++ "where" ++++
|
||||
" gf (" ++ gtyp +++ "s) =" +++ patt +++++
|
||||
"instance Fg" +++ gtyp +++ "where" ++++
|
||||
" fg t =" ++++
|
||||
" case t of" ++++
|
||||
" " +++ patt +++ " ->" +++ gtyp +++ "s" ++++
|
||||
" _ -> error (\"no" +++ gtyp +++ "\" ++ show t)"
|
||||
|
||||
type OIdent = String
|
||||
|
||||
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
|
||||
datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String
|
||||
datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
|
||||
gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g
|
||||
fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g
|
||||
|
||||
hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
|
||||
hDatatype ("Cn",_) = "" ---
|
||||
hDatatype (cat,[]) = ""
|
||||
hDatatype (cat,rules) | isListCat (cat,rules) =
|
||||
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
|
||||
+++ "deriving Show"
|
||||
hDatatype (cat,rules) =
|
||||
"data" +++ gId cat +++ "=" ++
|
||||
(if length rules == 1 then "" else "\n ") +++
|
||||
foldr1 (\x y -> x ++ "\n |" +++ y)
|
||||
[gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++
|
||||
" deriving Show"
|
||||
|
||||
-- GADT version of data types
|
||||
datatypesGADT :: (String,HSkeleton) -> String
|
||||
datatypesGADT (_,skel) =
|
||||
unlines (concatMap hCatTypeGADT skel)
|
||||
+++++
|
||||
"data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel)
|
||||
|
||||
hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hCatTypeGADT (cat,rules)
|
||||
= ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
|
||||
"data"+++gId cat++"_"]
|
||||
|
||||
hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hDatatypeGADT (cat, rules)
|
||||
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
|
||||
| otherwise =
|
||||
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
|
||||
where t = "Tree" +++ gId cat ++ "_"
|
||||
|
||||
|
||||
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
|
||||
hInstance m (cat,[]) = ""
|
||||
hInstance m (cat,rules)
|
||||
| isListCat (cat,rules) =
|
||||
"instance Gf" +++ gId cat +++ "where" ++++
|
||||
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
|
||||
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
|
||||
" gf (" ++ gId cat +++ "(x:xs)) = "
|
||||
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
|
||||
-- no show for GADTs
|
||||
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
|
||||
| otherwise =
|
||||
"instance Gf" +++ gId cat +++ "where" ++
|
||||
(if length rules == 1 then "" else "\n") +++
|
||||
foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules]
|
||||
where
|
||||
ec = elemCat cat
|
||||
baseVars = mkVars (baseSize (cat,rules))
|
||||
mkInst f xx = let xx' = mkVars (length xx) in "gf " ++
|
||||
(if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
|
||||
"=" +++ mkRHS f xx'
|
||||
mkVars n = ["x" ++ show i | i <- [1..n]]
|
||||
mkRHS f vars = "Tr (AC (CId \"" ++ f ++ "\"))" +++
|
||||
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
|
||||
|
||||
|
||||
----fInstance m ("Cn",_) = "" ---
|
||||
fInstance m (cat,[]) = ""
|
||||
fInstance m (cat,rules) =
|
||||
"instance Fg" +++ gId cat +++ "where" ++++
|
||||
" fg t =" ++++
|
||||
" case t of" ++++
|
||||
foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++
|
||||
" _ -> error (\"no" +++ cat ++ " \" ++ show t)"
|
||||
where
|
||||
mkInst f xx =
|
||||
" Tr (AC (CId \"" ++ f ++ "\")) " ++
|
||||
"[" ++ prTList "," xx' ++ "]" +++
|
||||
"->" +++ mkRHS f xx'
|
||||
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
|
||||
mkRHS f vars
|
||||
| isListCat (cat,rules) =
|
||||
if "Base" `isPrefixOf` f then
|
||||
gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
|
||||
else
|
||||
let (i,t) = (init vars,last vars)
|
||||
in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++
|
||||
gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"]))
|
||||
| otherwise =
|
||||
gId f +++
|
||||
prTList " " [prParenth ("fg" +++ x) | x <- vars]
|
||||
|
||||
|
||||
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
hSkeleton :: GFCC -> (String,HSkeleton)
|
||||
hSkeleton gr =
|
||||
(pr (absname gr),
|
||||
[(pr c, [(pr f, map pr cs) | (f, Typ cs _) <- fs]) |
|
||||
fs@((_, Typ _ c):_) <- fs]
|
||||
)
|
||||
where
|
||||
fs = groupBy valtypg (sortBy valtyps (Map.assocs (funs (abstract gr))))
|
||||
valtyps (_, Typ _ x) (_, Typ _ y) = compare x y
|
||||
valtypg (_, Typ _ x) (_, Typ _ y) = x == y
|
||||
pr (CId c) = c
|
||||
|
||||
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
|
||||
updateSkeleton cat skel rule =
|
||||
case skel of
|
||||
(cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
|
||||
(cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule
|
||||
|
||||
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
|
||||
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
|
||||
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
|
||||
where c = elemCat cat
|
||||
fs = map fst rules
|
||||
|
||||
-- | Gets the element category of a list category.
|
||||
elemCat :: OIdent -> OIdent
|
||||
elemCat = drop 4
|
||||
|
||||
isBaseFun :: OIdent -> Bool
|
||||
isBaseFun f = "Base" `isPrefixOf` f
|
||||
|
||||
isConsFun :: OIdent -> Bool
|
||||
isConsFun f = "Cons" `isPrefixOf` f
|
||||
|
||||
baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
|
||||
baseSize (_,rules) = length bs
|
||||
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
|
||||
@@ -1,78 +0,0 @@
|
||||
module GF.Canon.GFCC.GenGFCC where
|
||||
|
||||
import GF.Canon.GFCC.DataGFCC
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
|
||||
import qualified Data.Map as M
|
||||
import System.Random
|
||||
|
||||
-- generate an infinite list of trees exhaustively
|
||||
generate :: GFCC -> CId -> [Exp]
|
||||
generate gfcc cat = concatMap (\i -> gener i cat) [0..]
|
||||
where
|
||||
gener 0 c = [Tr (AC f) [] | (f, Typ [] _) <- fns c]
|
||||
gener i c = [
|
||||
tr |
|
||||
(f, Typ cs _) <- fns c,
|
||||
let alts = map (gener (i-1)) cs,
|
||||
ts <- combinations alts,
|
||||
let tr = Tr (AC f) ts,
|
||||
depth tr >= i
|
||||
]
|
||||
fns cat =
|
||||
let fs = maybe [] id $ M.lookup cat $ cats $ abstract gfcc
|
||||
in [(f,ty) | f <- fs, Just ty <- [M.lookup f $ funs $ abstract gfcc]]
|
||||
depth tr = case tr of
|
||||
Tr _ [] -> 1
|
||||
Tr _ ts -> maximum (map depth ts) + 1
|
||||
|
||||
combinations :: [[a]] -> [[a]]
|
||||
combinations t = case t of
|
||||
[] -> [[]]
|
||||
aa:uu -> [a:u | a <- aa, u <- combinations uu]
|
||||
|
||||
-- generate an infinite list of trees randomly
|
||||
generateRandom :: StdGen -> GFCC -> CId -> [Exp]
|
||||
generateRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0) gen) cat where
|
||||
|
||||
timeout = 47 -- give up
|
||||
|
||||
genTrees ds0 cat =
|
||||
let (ds,ds2) = splitAt (timeout+1) ds0 -- for time out, else ds
|
||||
(t,k) = genTree ds cat
|
||||
in (if k>timeout then id else (t:))
|
||||
(genTrees ds2 cat) -- else (drop k ds)
|
||||
|
||||
genTree rs = gett rs where
|
||||
gett ds (CId "String") = (Tr (AS "foo") [], 1)
|
||||
gett ds (CId "Int") = (Tr (AI 12345) [], 1)
|
||||
gett [] _ = (Tr (AS "TIMEOUT") [], 1) ----
|
||||
gett ds cat = case fns cat of
|
||||
[] -> (Tr AM [],1)
|
||||
fs -> let
|
||||
d:ds2 = ds
|
||||
(f,args) = getf d fs
|
||||
(ts,k) = getts ds2 args
|
||||
in (Tr (AC f) ts, k+1)
|
||||
getf d fs = let lg = (length fs) in
|
||||
fs !! (floor (d * fromIntegral lg))
|
||||
getts ds cats = case cats of
|
||||
c:cs -> let
|
||||
(t, k) = gett ds c
|
||||
(ts,ks) = getts (drop k ds) cs
|
||||
in (t:ts, k + ks)
|
||||
_ -> ([],0)
|
||||
|
||||
fns cat =
|
||||
let fs = maybe [] id $ M.lookup cat $ cats $ abstract gfcc
|
||||
in [(f,cs) | f <- fs,
|
||||
Just (Typ cs _) <- [M.lookup f $ funs $ abstract gfcc]]
|
||||
|
||||
-- brute-force parsing method; only returns the first result
|
||||
-- note: you cannot throw away rules with unknown words from the grammar
|
||||
-- because it is not known which field in each rule may match the input
|
||||
|
||||
parse :: Int -> GFCC -> CId -> [String] -> [Exp]
|
||||
parse i gfcc cat ws = [t | t <- gen, s <- lins t, words s == ws] where
|
||||
gen = take i $ generate gfcc cat
|
||||
lins t = [linearize gfcc lang t | lang <- cncnames gfcc]
|
||||
@@ -1,349 +0,0 @@
|
||||
{-# OPTIONS -fglasgow-exts -cpp #-}
|
||||
{-# LINE 3 "GF/Canon/GFCC/LexGFCC.x" #-}
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module GF.Canon.GFCC.LexGFCC where
|
||||
|
||||
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 603
|
||||
#include "ghcconfig.h"
|
||||
#else
|
||||
#include "config.h"
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 503
|
||||
import Data.Array
|
||||
import Data.Char (ord)
|
||||
import Data.Array.Base (unsafeAt)
|
||||
#else
|
||||
import Array
|
||||
import Char (ord)
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 503
|
||||
import GHC.Exts
|
||||
#else
|
||||
import GlaExts
|
||||
#endif
|
||||
alex_base :: AlexAddr
|
||||
alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xcb\xff\xff\xff\x0a\x00\x00\x00\xec\xff\xff\xff\x9a\x00\x00\x00\x6a\x01\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\xb8\x01\x00\x00"#
|
||||
|
||||
alex_table :: AlexAddr
|
||||
alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x0a\x00\x03\x00\x03\x00\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\xff\xff\x03\x00\x03\x00\x05\x00\xff\xff\x03\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x04\x00\xff\xff\x03\x00\xff\xff\x07\x00\xff\xff\x02\x00\x0f\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x03\x00\x06\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0a\x00\x00\x00\x00\x00\xff\xff\x07\x00\x0a\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0b\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x10\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\xLine truncated
|
||||
|
||||
alex_check :: AlexAddr
|
||||
alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7c\x00\x3e\x00\x5d\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xLine truncated
|
||||
|
||||
alex_deflt :: AlexAddr
|
||||
alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
|
||||
|
||||
alex_accept = listArray (0::Int,17) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[],[],[]]
|
||||
{-# LINE 33 "GF/Canon/GFCC/LexGFCC.x" #-}
|
||||
|
||||
tok f p s = f p s
|
||||
|
||||
share :: String -> String
|
||||
share = id
|
||||
|
||||
data Tok =
|
||||
TS !String -- reserved words and symbols
|
||||
| TL !String -- string literals
|
||||
| TI !String -- integer literals
|
||||
| TV !String -- identifiers
|
||||
| TD !String -- double precision float literals
|
||||
| TC !String -- character literals
|
||||
| T_CId !String
|
||||
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
data Token =
|
||||
PT Posn Tok
|
||||
| Err Posn
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
|
||||
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
|
||||
tokenPos _ = "end of file"
|
||||
|
||||
posLineCol (Pn _ l c) = (l,c)
|
||||
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
|
||||
|
||||
prToken t = case t of
|
||||
PT _ (TS s) -> s
|
||||
PT _ (TI s) -> s
|
||||
PT _ (TV s) -> s
|
||||
PT _ (TD s) -> s
|
||||
PT _ (TC s) -> s
|
||||
PT _ (T_CId s) -> s
|
||||
|
||||
_ -> show t
|
||||
|
||||
data BTree = N | B String Tok BTree BTree deriving (Show)
|
||||
|
||||
eitherResIdent :: (String -> Tok) -> String -> Tok
|
||||
eitherResIdent tv s = treeFind resWords
|
||||
where
|
||||
treeFind N = tv s
|
||||
treeFind (B a t left right) | s < a = treeFind left
|
||||
| s > a = treeFind right
|
||||
| s == a = t
|
||||
|
||||
resWords = b "grammar" (b "concrete" (b "abstract" N N) N) (b "pre" N N)
|
||||
where b s = B s (TS s)
|
||||
|
||||
unescapeInitTail :: String -> String
|
||||
unescapeInitTail = unesc . tail where
|
||||
unesc s = case s of
|
||||
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
|
||||
'\\':'n':cs -> '\n' : unesc cs
|
||||
'\\':'t':cs -> '\t' : unesc cs
|
||||
'"':[] -> []
|
||||
c:cs -> c : unesc cs
|
||||
_ -> []
|
||||
|
||||
-------------------------------------------------------------------
|
||||
-- Alex wrapper code.
|
||||
-- A modified "posn" wrapper.
|
||||
-------------------------------------------------------------------
|
||||
|
||||
data Posn = Pn !Int !Int !Int
|
||||
deriving (Eq, Show,Ord)
|
||||
|
||||
alexStartPos :: Posn
|
||||
alexStartPos = Pn 0 1 1
|
||||
|
||||
alexMove :: Posn -> Char -> Posn
|
||||
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
|
||||
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
|
||||
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
|
||||
|
||||
type AlexInput = (Posn, -- current position,
|
||||
Char, -- previous char
|
||||
String) -- current input string
|
||||
|
||||
tokens :: String -> [Token]
|
||||
tokens str = go (alexStartPos, '\n', str)
|
||||
where
|
||||
go :: (Posn, Char, String) -> [Token]
|
||||
go inp@(pos, _, str) =
|
||||
case alexScan inp 0 of
|
||||
AlexEOF -> []
|
||||
AlexError (pos, _, _) -> [Err pos]
|
||||
AlexSkip inp' len -> go inp'
|
||||
AlexToken inp' len act -> act pos (take len str) : (go inp')
|
||||
|
||||
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
|
||||
alexGetChar (p, c, []) = Nothing
|
||||
alexGetChar (p, _, (c:s)) =
|
||||
let p' = alexMove p c
|
||||
in p' `seq` Just (c, (p', c, s))
|
||||
|
||||
alexInputPrevChar :: AlexInput -> Char
|
||||
alexInputPrevChar (p, c, s) = c
|
||||
|
||||
alex_action_1 = tok (\p s -> PT p (TS $ share s))
|
||||
alex_action_2 = tok (\p s -> PT p (eitherResIdent (T_CId . share) s))
|
||||
alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s))
|
||||
alex_action_4 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s))
|
||||
alex_action_5 = tok (\p s -> PT p (TI $ share s))
|
||||
alex_action_6 = tok (\p s -> PT p (TD $ share s))
|
||||
{-# LINE 1 "GenericTemplate.hs" #-}
|
||||
{-# LINE 1 "<built-in>" #-}
|
||||
{-# LINE 1 "<command line>" #-}
|
||||
{-# LINE 1 "GenericTemplate.hs" #-}
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- ALEX TEMPLATE
|
||||
--
|
||||
-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
|
||||
-- it for any purpose whatsoever.
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- INTERNALS and main scanner engine
|
||||
|
||||
|
||||
{-# LINE 35 "GenericTemplate.hs" #-}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data AlexAddr = AlexA# Addr#
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 503
|
||||
uncheckedShiftL# = shiftL#
|
||||
#endif
|
||||
|
||||
{-# INLINE alexIndexInt16OffAddr #-}
|
||||
alexIndexInt16OffAddr (AlexA# arr) off =
|
||||
#ifdef WORDS_BIGENDIAN
|
||||
narrow16Int# i
|
||||
where
|
||||
i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
|
||||
high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
|
||||
low = int2Word# (ord# (indexCharOffAddr# arr off'))
|
||||
off' = off *# 2#
|
||||
#else
|
||||
indexInt16OffAddr# arr off
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
{-# INLINE alexIndexInt32OffAddr #-}
|
||||
alexIndexInt32OffAddr (AlexA# arr) off =
|
||||
#ifdef WORDS_BIGENDIAN
|
||||
narrow32Int# i
|
||||
where
|
||||
i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
|
||||
(b2 `uncheckedShiftL#` 16#) `or#`
|
||||
(b1 `uncheckedShiftL#` 8#) `or#` b0)
|
||||
b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
|
||||
b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
|
||||
b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
|
||||
b0 = int2Word# (ord# (indexCharOffAddr# arr off'))
|
||||
off' = off *# 4#
|
||||
#else
|
||||
indexInt32OffAddr# arr off
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 503
|
||||
quickIndex arr i = arr ! i
|
||||
#else
|
||||
-- GHC >= 503, unsafeAt is available from Data.Array.Base.
|
||||
quickIndex = unsafeAt
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Main lexing routines
|
||||
|
||||
data AlexReturn a
|
||||
= AlexEOF
|
||||
| AlexError !AlexInput
|
||||
| AlexSkip !AlexInput !Int
|
||||
| AlexToken !AlexInput !Int a
|
||||
|
||||
-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act)
|
||||
alexScan input (I# (sc))
|
||||
= alexScanUser undefined input (I# (sc))
|
||||
|
||||
alexScanUser user input (I# (sc))
|
||||
= case alex_scan_tkn user input 0# input sc AlexNone of
|
||||
(AlexNone, input') ->
|
||||
case alexGetChar input of
|
||||
Nothing ->
|
||||
|
||||
|
||||
|
||||
AlexEOF
|
||||
Just _ ->
|
||||
|
||||
|
||||
|
||||
AlexError input'
|
||||
|
||||
(AlexLastSkip input len, _) ->
|
||||
|
||||
|
||||
|
||||
AlexSkip input len
|
||||
|
||||
(AlexLastAcc k input len, _) ->
|
||||
|
||||
|
||||
|
||||
AlexToken input len k
|
||||
|
||||
|
||||
-- Push the input through the DFA, remembering the most recent accepting
|
||||
-- state it encountered.
|
||||
|
||||
alex_scan_tkn user orig_input len input s last_acc =
|
||||
input `seq` -- strict in the input
|
||||
case s of
|
||||
-1# -> (last_acc, input)
|
||||
_ -> alex_scan_tkn' user orig_input len input s last_acc
|
||||
|
||||
alex_scan_tkn' user orig_input len input s last_acc =
|
||||
let
|
||||
new_acc = check_accs (alex_accept `quickIndex` (I# (s)))
|
||||
in
|
||||
new_acc `seq`
|
||||
case alexGetChar input of
|
||||
Nothing -> (new_acc, input)
|
||||
Just (c, new_input) ->
|
||||
|
||||
|
||||
|
||||
let
|
||||
base = alexIndexInt32OffAddr alex_base s
|
||||
(I# (ord_c)) = ord c
|
||||
offset = (base +# ord_c)
|
||||
check = alexIndexInt16OffAddr alex_check offset
|
||||
|
||||
new_s = if (offset >=# 0#) && (check ==# ord_c)
|
||||
then alexIndexInt16OffAddr alex_table offset
|
||||
else alexIndexInt16OffAddr alex_deflt s
|
||||
in
|
||||
alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc
|
||||
|
||||
where
|
||||
check_accs [] = last_acc
|
||||
check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
|
||||
check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))
|
||||
check_accs (AlexAccPred a pred : rest)
|
||||
| pred user orig_input (I# (len)) input
|
||||
= AlexLastAcc a input (I# (len))
|
||||
check_accs (AlexAccSkipPred pred : rest)
|
||||
| pred user orig_input (I# (len)) input
|
||||
= AlexLastSkip input (I# (len))
|
||||
check_accs (_ : rest) = check_accs rest
|
||||
|
||||
data AlexLastAcc a
|
||||
= AlexNone
|
||||
| AlexLastAcc a !AlexInput !Int
|
||||
| AlexLastSkip !AlexInput !Int
|
||||
|
||||
data AlexAcc a user
|
||||
= AlexAcc a
|
||||
| AlexAccSkip
|
||||
| AlexAccPred a (AlexAccPred user)
|
||||
| AlexAccSkipPred (AlexAccPred user)
|
||||
|
||||
type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Predicates on a rule
|
||||
|
||||
alexAndPred p1 p2 user in1 len in2
|
||||
= p1 user in1 len in2 && p2 user in1 len in2
|
||||
|
||||
--alexPrevCharIsPred :: Char -> AlexAccPred _
|
||||
alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input
|
||||
|
||||
--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _
|
||||
alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
|
||||
|
||||
--alexRightContext :: Int -> AlexAccPred _
|
||||
alexRightContext (I# (sc)) user _ _ input =
|
||||
case alex_scan_tkn user input 0# input sc AlexNone of
|
||||
(AlexNone, _) -> False
|
||||
_ -> True
|
||||
-- TODO: there's no need to find the longest
|
||||
-- match when checking the right context, just
|
||||
-- the first match will do.
|
||||
|
||||
-- used by wrappers
|
||||
iUnbox (I# (i)) = i
|
||||
File diff suppressed because it is too large.
Load diff
@@ -1,190 +0,0 @@
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module GF.Canon.GFCC.PrintGFCC where
|
||||
|
||||
-- pretty-printer generated by the BNF converter
|
||||
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
import Data.Char
|
||||
|
||||
-- the top-level printing method
|
||||
printTree :: Print a => a -> String
|
||||
printTree = render . prt 0
|
||||
|
||||
type Doc = [ShowS] -> [ShowS]
|
||||
|
||||
doc :: ShowS -> Doc
|
||||
doc = (:)
|
||||
|
||||
render :: Doc -> String
|
||||
render d = rend 0 (map ($ "") $ d []) "" where
|
||||
rend i ss = case ss of
|
||||
"[" :ts -> showChar '[' . rend i ts
|
||||
"(" :ts -> showChar '(' . rend i ts
|
||||
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
|
||||
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
|
||||
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
|
||||
";" :ts -> showChar ';' . new i . rend i ts
|
||||
t : "," :ts -> showString t . space "," . rend i ts
|
||||
t : ")" :ts -> showString t . showChar ')' . rend i ts
|
||||
t : "]" :ts -> showString t . showChar ']' . rend i ts
|
||||
t :ts -> space t . rend i ts
|
||||
_ -> id
|
||||
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
|
||||
space t = showString t ---- . (\s -> if null s then "" else (' ':s))
|
||||
|
||||
parenth :: Doc -> Doc
|
||||
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
|
||||
|
||||
concatS :: [ShowS] -> ShowS
|
||||
concatS = foldr (.) id
|
||||
|
||||
concatD :: [Doc] -> Doc
|
||||
concatD = foldr (.) id
|
||||
|
||||
replicateS :: Int -> ShowS -> ShowS
|
||||
replicateS n f = concatS (replicate n f)
|
||||
|
||||
-- the printer class does the job
|
||||
class Print a where
|
||||
prt :: Int -> a -> Doc
|
||||
prtList :: [a] -> Doc
|
||||
prtList = concatD . map (prt 0)
|
||||
|
||||
instance Print a => Print [a] where
|
||||
prt _ = prtList
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
|
||||
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
|
||||
|
||||
mkEsc :: Char -> Char -> ShowS
|
||||
mkEsc q s = case s of
|
||||
_ | s == q -> showChar '\\' . showChar s
|
||||
'\\'-> showString "\\\\"
|
||||
'\n' -> showString "\\n"
|
||||
'\t' -> showString "\\t"
|
||||
_ -> showChar s
|
||||
|
||||
prPrec :: Int -> Int -> Doc -> Doc
|
||||
prPrec i j = if j<i then parenth else id
|
||||
|
||||
|
||||
instance Print Integer where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
instance Print Int where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
instance Print Double where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
|
||||
instance Print CId where
|
||||
prt _ (CId i) = doc (showString i)
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
|
||||
|
||||
instance Print Grammar where
|
||||
prt i e = case e of
|
||||
Grm header abstract concretes -> prPrec i 0 (concatD [prt 0 header , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
|
||||
|
||||
|
||||
instance Print Header where
|
||||
prt i e = case e of
|
||||
Hdr cid cids -> prPrec i 0 (concatD [doc (showString "grammar ") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")")])
|
||||
|
||||
|
||||
instance Print Abstract where
|
||||
prt i e = case e of
|
||||
Abs absdefs -> prPrec i 0 (concatD [doc (showString "abstract ") , doc (showString "{") , prt 0 absdefs , doc (showString "}")])
|
||||
|
||||
|
||||
instance Print Concrete where
|
||||
prt i e = case e of
|
||||
Cnc cid cncdefs -> prPrec i 0 (concatD [doc (showString "concrete ") , prt 0 cid , doc (showString "{") , prt 0 cncdefs , doc (showString "}")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print AbsDef where
|
||||
prt i e = case e of
|
||||
Fun cid type' exp -> prPrec i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print CncDef where
|
||||
prt i e = case e of
|
||||
Lin cid term -> prPrec i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Type where
|
||||
prt i e = case e of
|
||||
Typ cids cid -> prPrec i 0 (concatD [prt 0 cids , doc (showString "->") , prt 0 cid])
|
||||
|
||||
|
||||
instance Print Exp where
|
||||
prt i e = case e of
|
||||
Tr atom exps -> prPrec i 0 (concatD [doc (showString "(") , prt 0 atom , prt 0 exps , doc (showString ")")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print Atom where
|
||||
prt i e = case e of
|
||||
AC cid -> prPrec i 0 (concatD [prt 0 cid])
|
||||
AS str -> prPrec i 0 (concatD [prt 0 str])
|
||||
AI n -> prPrec i 0 (concatD [prt 0 n])
|
||||
AF d -> prPrec i 0 (concatD [prt 0 d])
|
||||
AM -> prPrec i 0 (concatD [doc (showString "?")])
|
||||
|
||||
|
||||
instance Print Term where
|
||||
prt i e = case e of
|
||||
R terms -> prPrec i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
|
||||
P term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term , doc (showString ")")])
|
||||
S terms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
|
||||
K tokn -> prPrec i 0 (concatD [prt 0 tokn])
|
||||
V n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
|
||||
C n -> prPrec i 0 (concatD [prt 0 n])
|
||||
F cid -> prPrec i 0 (concatD [prt 0 cid])
|
||||
FV terms -> prPrec i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
|
||||
W str term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
|
||||
RP term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term , doc (showString ")")])
|
||||
TM -> prPrec i 0 (concatD [doc (showString "?")])
|
||||
L cid term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cid , doc (showString "->") , prt 0 term , doc (showString ")")])
|
||||
BV cid -> prPrec i 0 (concatD [doc (showString "#") , prt 0 cid])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print Tokn where
|
||||
prt i e = case e of
|
||||
KS str -> prPrec i 0 (concatD [prt 0 str])
|
||||
KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
|
||||
|
||||
|
||||
instance Print Variant where
|
||||
prt i e = case e of
|
||||
Var strs0 strs -> prPrec i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
|
||||
@@ -1,75 +0,0 @@
|
||||
module Main where
|
||||
|
||||
import GF.Canon.GFCC.GenGFCC
|
||||
import GF.Canon.GFCC.DataGFCC
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
import GF.Canon.GFCC.ParGFCC
|
||||
import GF.Canon.GFCC.PrintGFCC
|
||||
import GF.Canon.GFCC.ErrM
|
||||
--import GF.Data.Operations
|
||||
import Data.Map
|
||||
import System.Random (newStdGen)
|
||||
import System
|
||||
|
||||
-- Simple translation application built on GFCC. AR 7/9/2006
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
file:_ <- getArgs
|
||||
grammar <- file2gfcc file
|
||||
putStrLn $ statGFCC grammar
|
||||
loop grammar
|
||||
|
||||
loop :: GFCC -> IO ()
|
||||
loop grammar = do
|
||||
s <- getLine
|
||||
if s == "quit" then return () else do
|
||||
treat grammar s
|
||||
loop grammar
|
||||
|
||||
treat :: GFCC -> String -> IO ()
|
||||
treat grammar s = case words s of
|
||||
"gt":cat:n:_ -> do
|
||||
mapM_ prlinonly $ take (read n) $ generate grammar (CId cat)
|
||||
"gtt":cat:n:_ -> do
|
||||
mapM_ prlin $ take (read n) $ generate grammar (CId cat)
|
||||
"gr":cat:n:_ -> do
|
||||
gen <- newStdGen
|
||||
mapM_ prlinonly $ take (read n) $ generateRandom gen grammar (CId cat)
|
||||
"grt":cat:n:_ -> do
|
||||
gen <- newStdGen
|
||||
mapM_ prlin $ take (read n) $ generateRandom gen grammar (CId cat)
|
||||
"p":cat:n:ws -> do
|
||||
case parse (read n) grammar (CId cat) ws of
|
||||
t:_ -> prlin t
|
||||
_ -> putStrLn "no parse found"
|
||||
_ -> lins $ readExp s
|
||||
where
|
||||
lins t = mapM_ (lint t) $ cncnames grammar
|
||||
lint t lang = do
|
||||
putStrLn $ printTree $ linExp grammar lang t
|
||||
lin t lang
|
||||
lin t lang = do
|
||||
putStrLn $ linearize grammar lang t
|
||||
prlins t = do
|
||||
putStrLn $ printTree t
|
||||
lins t
|
||||
prlin t = do
|
||||
putStrLn $ printTree t
|
||||
prlinonly t
|
||||
prlinonly t = mapM_ (lin t) $ cncnames grammar
|
||||
|
||||
|
||||
--- should be in an API
|
||||
|
||||
file2gfcc :: FilePath -> IO GFCC
|
||||
file2gfcc f =
|
||||
readFile f >>= err (error "no parse") (return . mkGFCC) . pGrammar . myLexer
|
||||
|
||||
readExp :: String -> Exp
|
||||
readExp = err (const exp0) id . (pExp . myLexer)
|
||||
|
||||
err f g ex = case ex of
|
||||
Ok x -> g x
|
||||
Bad s -> f s
|
||||
|
||||
@@ -1,74 +0,0 @@
|
||||
module Main where
|
||||
|
||||
import GF.Canon.GFCC.GFCCAPI
|
||||
import qualified GF.Canon.GFCC.GenGFCC as G ---
|
||||
import GF.Canon.GFCC.AbsGFCC (CId(CId)) ---
|
||||
import System.Random (newStdGen)
|
||||
import System (getArgs)
|
||||
import Data.Char (isDigit)
|
||||
|
||||
-- Simple translation application built on GFCC. AR 7/9/2006 -- 19/9/2007
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
file:_ <- getArgs
|
||||
grammar <- file2grammar file
|
||||
printHelp grammar
|
||||
loop grammar
|
||||
|
||||
loop :: MultiGrammar -> IO ()
|
||||
loop grammar = do
|
||||
s <- getLine
|
||||
if s == "q" then return () else do
|
||||
treat grammar s
|
||||
loop grammar
|
||||
|
||||
printHelp grammar = do
|
||||
putStrLn $ "languages: " ++ unwords (languages grammar)
|
||||
putStrLn $ "categories: " ++ unwords (categories grammar)
|
||||
putStrLn commands
|
||||
|
||||
|
||||
commands = unlines [
|
||||
"Commands:",
|
||||
" (gt | gtt | gr | grt) Cat Num - generate all or random",
|
||||
" p Lang Cat String - parse (unquoted) string",
|
||||
" l Tree - linearize in all languages",
|
||||
" h - help",
|
||||
" q - quit"
|
||||
]
|
||||
|
||||
treat :: MultiGrammar -> String -> IO ()
|
||||
treat mgr s = case words s of
|
||||
"gt" :cat:n:_ -> mapM_ prlinonly $ take (read1 n) $ generateAll mgr cat
|
||||
"gtt":cat:n:_ -> mapM_ prlin $ take (read1 n) $ generateAll mgr cat
|
||||
"gr" :cat:n:_ -> generateRandom mgr cat >>= mapM_ prlinonly . take (read1 n)
|
||||
"grt":cat:n:_ -> generateRandom mgr cat >>= mapM_ prlin . take (read1 n)
|
||||
"p":lang:cat:ws -> do
|
||||
let ts = parse mgr lang cat $ unwords ws
|
||||
mapM_ (putStrLn . showTree) ts
|
||||
"search":cat:n:ws -> do
|
||||
case G.parse (read n) grammar (CId cat) ws of
|
||||
t:_ -> prlin t
|
||||
_ -> putStrLn "no parse found"
|
||||
"h":_ -> printHelp mgr
|
||||
_ -> lins $ readTree mgr s
|
||||
where
|
||||
grammar = gfcc mgr
|
||||
langs = languages mgr
|
||||
lins t = mapM_ (lint t) $ langs
|
||||
lint t lang = do
|
||||
---- putStrLn $ showTree $ linExp grammar lang t
|
||||
lin t lang
|
||||
lin t lang = do
|
||||
putStrLn $ linearize mgr lang t
|
||||
prlins t = do
|
||||
putStrLn $ showTree t
|
||||
lins t
|
||||
prlin t = do
|
||||
putStrLn $ showTree t
|
||||
prlinonly t
|
||||
prlinonly t = mapM_ (lin t) $ langs
|
||||
read1 s = if all isDigit s then read s else 1
|
||||
|
||||
|
||||
@@ -1,94 +0,0 @@
|
||||
module GF.Canon.GFCC.SkelGFCC where
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
import GF.Canon.GFCC.ErrM
|
||||
type Result = Err String
|
||||
|
||||
failure :: Show a => a -> Result
|
||||
failure x = Bad $ "Undefined case: " ++ show x
|
||||
|
||||
transCId :: CId -> Result
|
||||
transCId x = case x of
|
||||
CId str -> failure x
|
||||
|
||||
|
||||
transGrammar :: Grammar -> Result
|
||||
transGrammar x = case x of
|
||||
Grm header abstract concretes -> failure x
|
||||
|
||||
|
||||
transHeader :: Header -> Result
|
||||
transHeader x = case x of
|
||||
Hdr cid cids -> failure x
|
||||
|
||||
|
||||
transAbstract :: Abstract -> Result
|
||||
transAbstract x = case x of
|
||||
Abs absdefs -> failure x
|
||||
|
||||
|
||||
transConcrete :: Concrete -> Result
|
||||
transConcrete x = case x of
|
||||
Cnc cid cncdefs -> failure x
|
||||
|
||||
|
||||
transAbsDef :: AbsDef -> Result
|
||||
transAbsDef x = case x of
|
||||
Fun cid type' exp -> failure x
|
||||
|
||||
|
||||
transCncDef :: CncDef -> Result
|
||||
transCncDef x = case x of
|
||||
Lin cid term -> failure x
|
||||
|
||||
|
||||
transType :: Type -> Result
|
||||
transType x = case x of
|
||||
Typ cids cid -> failure x
|
||||
|
||||
|
||||
transExp :: Exp -> Result
|
||||
transExp x = case x of
|
||||
Tr atom exps -> failure x
|
||||
|
||||
|
||||
transAtom :: Atom -> Result
|
||||
transAtom x = case x of
|
||||
AC cid -> failure x
|
||||
AS str -> failure x
|
||||
AI n -> failure x
|
||||
AF d -> failure x
|
||||
AM -> failure x
|
||||
|
||||
|
||||
transTerm :: Term -> Result
|
||||
transTerm x = case x of
|
||||
R terms -> failure x
|
||||
P term0 term -> failure x
|
||||
S terms -> failure x
|
||||
K tokn -> failure x
|
||||
V n -> failure x
|
||||
C n -> failure x
|
||||
F cid -> failure x
|
||||
FV terms -> failure x
|
||||
W str term -> failure x
|
||||
RP term0 term -> failure x
|
||||
TM -> failure x
|
||||
L cid term -> failure x
|
||||
BV cid -> failure x
|
||||
|
||||
|
||||
transTokn :: Tokn -> Result
|
||||
transTokn x = case x of
|
||||
KS str -> failure x
|
||||
KP strs variants -> failure x
|
||||
|
||||
|
||||
transVariant :: Variant -> Result
|
||||
transVariant x = case x of
|
||||
Var strs0 strs -> failure x
|
||||
|
||||
|
||||
|
||||
@@ -1,58 +0,0 @@
|
||||
-- automatically generated by BNF Converter
|
||||
module Main where
|
||||
|
||||
|
||||
import IO ( stdin, hGetContents )
|
||||
import System ( getArgs, getProgName )
|
||||
|
||||
import GF.Canon.GFCC.LexGFCC
|
||||
import GF.Canon.GFCC.ParGFCC
|
||||
import GF.Canon.GFCC.SkelGFCC
|
||||
import GF.Canon.GFCC.PrintGFCC
|
||||
import GF.Canon.GFCC.AbsGFCC
|
||||
|
||||
|
||||
|
||||
|
||||
import GF.Canon.GFCC.ErrM
|
||||
|
||||
type ParseFun a = [Token] -> Err a
|
||||
|
||||
myLLexer = myLexer
|
||||
|
||||
type Verbosity = Int
|
||||
|
||||
putStrV :: Verbosity -> String -> IO ()
|
||||
putStrV v s = if v > 1 then putStrLn s else return ()
|
||||
|
||||
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
|
||||
runFile v p f = putStrLn f >> readFile f >>= run v p
|
||||
|
||||
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
|
||||
run v p s = let ts = myLLexer s in case p ts of
|
||||
Bad s -> do putStrLn "\nParse Failed...\n"
|
||||
putStrV v "Tokens:"
|
||||
putStrV v $ show ts
|
||||
putStrLn s
|
||||
Ok tree -> do putStrLn "\nParse Successful!"
|
||||
showTree v tree
|
||||
|
||||
|
||||
|
||||
showTree :: (Show a, Print a) => Int -> a -> IO ()
|
||||
showTree v tree
|
||||
= do
|
||||
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
|
||||
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
|
||||
|
||||
main :: IO ()
|
||||
main = do args <- getArgs
|
||||
case args of
|
||||
[] -> hGetContents stdin >>= run 2 pGrammar
|
||||
"-s":fs -> mapM_ (runFile 0 pGrammar) fs
|
||||
fs -> mapM_ (runFile 2 pGrammar) fs
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
Reference in new issue
Block a user