mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
removed Canon/GFCC
This commit is contained in:
aarne
@@ -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]
|
||||
File diff suppressed because one or more lines are too long
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user