mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-24 03:52:50 -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