forked from GitHub/gf-core
new GFCC concrete syntax in place everywhere
This commit is contained in:
aarne
@@ -19,8 +19,9 @@ import GF.GFCC.Linearize
|
||||
import GF.GFCC.Generate
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.ParGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.Raw.ConvertGFCC
|
||||
import GF.GFCC.Raw.ParGFCCRaw
|
||||
import GF.Command.PPrTree
|
||||
|
||||
import GF.GFCC.ErrM
|
||||
@@ -81,8 +82,10 @@ file2grammar f = do
|
||||
gfcc2parsers gfcc =
|
||||
[(lang, buildFCFPInfo fcfg) | (CId lang,fcfg) <- convertGrammar gfcc]
|
||||
|
||||
file2gfcc f =
|
||||
readFileIf f >>= err (error) (return . mkGFCC) . pGrammar . myLexer
|
||||
file2gfcc f = do
|
||||
s <- readFileIf f
|
||||
g <- parseGrammar s
|
||||
return $ toGFCC g
|
||||
|
||||
linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (CId lang)
|
||||
|
||||
|
||||
@@ -1,82 +0,0 @@
|
||||
module GF.GFCC.AbsGFCC where
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
newtype CId = CId String deriving (Eq,Ord,Show)
|
||||
data Grammar =
|
||||
Grm CId [CId] [Flag] Abstract [Concrete]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Abstract =
|
||||
Abs [Flag] [FunDef] [CatDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Concrete =
|
||||
Cnc CId [Flag] [LinDef] [LinDef] [LinDef] [LinDef] [LinDef] [LinDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Flag =
|
||||
Flg CId String
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data CatDef =
|
||||
Cat CId [Hypo]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data FunDef =
|
||||
Fun CId Type Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinDef =
|
||||
Lin CId Term
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Type =
|
||||
DTyp [Hypo] CId [Exp]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Exp =
|
||||
DTr [CId] Atom [Exp]
|
||||
| EEq [Equation]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Atom =
|
||||
AC CId
|
||||
| AS String
|
||||
| AI Integer
|
||||
| AF Double
|
||||
| AM Integer
|
||||
| AV CId
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Term =
|
||||
R [Term]
|
||||
| P Term Term
|
||||
| S [Term]
|
||||
| K Tokn
|
||||
| V Int --H
|
||||
| C Int --H
|
||||
| F CId
|
||||
| FV [Term]
|
||||
| W String Term
|
||||
| TM
|
||||
| RP Term Term
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Tokn =
|
||||
KS String
|
||||
| KP [String] [Variant]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Variant =
|
||||
Var [String] [String]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Hypo =
|
||||
Hyp CId Type
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Equation =
|
||||
Equ [Exp] Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
@@ -1,8 +1,8 @@
|
||||
module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio) where
|
||||
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.ErrM
|
||||
|
||||
import qualified Data.Map as Map
|
||||
@@ -39,7 +39,7 @@ labelBoolErr ms iob = do
|
||||
|
||||
checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool)
|
||||
checkConcrete gfcc (lang,cnc) =
|
||||
labelBoolErr ("happened in language " ++ prt lang) $ do
|
||||
labelBoolErr ("happened in language " ++ printCId lang) $ do
|
||||
(rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
|
||||
return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
|
||||
where
|
||||
@@ -47,7 +47,7 @@ checkConcrete gfcc (lang,cnc) =
|
||||
|
||||
checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
|
||||
checkLin gfcc lang (f,t) =
|
||||
labelBoolErr ("happened in function " ++ prt f) $ do
|
||||
labelBoolErr ("happened in function " ++ printCId f) $ do
|
||||
(t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t
|
||||
return ((f,t'),b)
|
||||
|
||||
@@ -62,7 +62,7 @@ inferTerm args trm = case trm of
|
||||
(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'))
|
||||
("expected Str in " ++ show trm ++ " not " ++ unwords (map show tys'))
|
||||
return (S ts',str)
|
||||
R ts -> do
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
@@ -78,21 +78,21 @@ inferTerm args trm = case trm of
|
||||
|
||||
C i -> do
|
||||
testErr (i < length tys)
|
||||
("required more than " ++ show i ++ " fields in " ++ prt (R tys))
|
||||
("required more than " ++ show i ++ " fields in " ++ show (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)
|
||||
testErr (all (==typ) tys) ("different types in table " ++ show trm)
|
||||
return (P t' u', typ) -- table: types must be same
|
||||
_ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt
|
||||
_ -> Bad $ "projection from " ++ show t ++ " : " ++ show tt
|
||||
FV [] -> returnt TM ----
|
||||
FV (t:ts) -> do
|
||||
(t',ty) <- infer t
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
testErr (all (eqType ty) tys) ("different types in variants " ++ prt trm)
|
||||
testErr (all (eqType ty) tys) ("different types in variants " ++ show trm)
|
||||
return (FV (t':ts'),ty)
|
||||
W s r -> infer r
|
||||
_ -> Bad ("no type inference for " ++ prt trm)
|
||||
_ -> Bad ("no type inference for " ++ show trm)
|
||||
where
|
||||
returnt ty = return (trm,ty)
|
||||
infer = inferTerm args
|
||||
@@ -102,9 +102,9 @@ checkTerm (args,val) trm = case inferTerm args trm of
|
||||
Ok (t,ty) -> if eqType ty val
|
||||
then return (t,True)
|
||||
else do
|
||||
msg ("term: " ++ prt trm ++
|
||||
"\nexpected type: " ++ prt val ++
|
||||
"\ninferred type: " ++ prt ty)
|
||||
msg ("term: " ++ show trm ++
|
||||
"\nexpected type: " ++ show val ++
|
||||
"\ninferred type: " ++ show ty)
|
||||
return (t,False)
|
||||
Bad s -> do
|
||||
msg s
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
module GF.GFCC.DataGFCC where
|
||||
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.PrintGFCC
|
||||
import GF.Infra.CompactPrint
|
||||
import GF.Text.UTF8
|
||||
|
||||
|
||||
@@ -2,7 +2,7 @@ module GF.GFCC.Generate where
|
||||
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
|
||||
import qualified Data.Map as M
|
||||
import System.Random
|
||||
|
||||
@@ -2,7 +2,7 @@ module GF.GFCC.Linearize where
|
||||
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import Data.Map
|
||||
import Data.List
|
||||
|
||||
@@ -56,7 +56,7 @@ compute mcfg lang args = comp where
|
||||
|
||||
idx xs i = if i > length xs - 1
|
||||
then trace
|
||||
("too large " ++ show i ++ " for\n" ++ unlines (lmap prt xs) ++ "\n") TM
|
||||
("too large " ++ show i ++ " for\n" ++ unlines (lmap show xs) ++ "\n") TM
|
||||
else xs !! i
|
||||
|
||||
proj r p = case (r,p) of
|
||||
|
||||
@@ -1,8 +1,8 @@
|
||||
module GF.GFCC.Macros where
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.PrintGFCC
|
||||
----import GF.GFCC.PrintGFCC
|
||||
import Data.Map
|
||||
import Data.List
|
||||
|
||||
@@ -83,9 +83,6 @@ term0 _ = TM
|
||||
kks :: String -> Term
|
||||
kks = K . KS
|
||||
|
||||
prt :: Print a => a -> String
|
||||
prt = printTree
|
||||
|
||||
-- lookup with default value
|
||||
lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a
|
||||
lookMap d c m = maybe d id $ Data.Map.lookup c m
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
module GF.GFCC.OptimizeGFCC where
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.DataGFCC
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,217 +0,0 @@
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module GF.GFCC.PrintGFCC where
|
||||
|
||||
-- pretty-printer generated by the BNF converter
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import 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 --H
|
||||
prt _ x = doc (shows x) --H
|
||||
|
||||
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 cid cids flags abstract concretes -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")") , doc (showString "(") , prt 0 flags , doc (showString ")") , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
|
||||
|
||||
|
||||
instance Print Abstract where
|
||||
prt i e = case e of
|
||||
Abs flags fundefs catdefs -> prPrec i 0 (concatD [doc (showString "abstract") , doc (showString "{") , doc (showString "flags") , prt 0 flags , doc (showString "fun") , prt 0 fundefs , doc (showString "cat") , prt 0 catdefs , doc (showString "}")])
|
||||
|
||||
|
||||
instance Print Concrete where
|
||||
prt i e = case e of
|
||||
Cnc cid flags lindefs0 lindefs1 lindefs2 lindefs3 lindefs4 lindefs -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 cid , doc (showString "{") , doc (showString "flags") , prt 0 flags , doc (showString "lin") , prt 0 lindefs0 , doc (showString "oper") , prt 0 lindefs1 , doc (showString "lincat") , prt 0 lindefs2 , doc (showString "lindef") , prt 0 lindefs3 , doc (showString "printname") , prt 0 lindefs4 , doc (showString "param") , prt 0 lindefs , doc (showString "}")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Flag where
|
||||
prt i e = case e of
|
||||
Flg cid str -> prPrec i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 str])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print CatDef where
|
||||
prt i e = case e of
|
||||
Cat cid hypos -> prPrec i 0 (concatD [prt 0 cid , doc (showString "[") , prt 0 hypos , doc (showString "]")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print FunDef 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 LinDef 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
|
||||
DTyp hypos cid exps -> prPrec i 0 (concatD [doc (showString "[") , prt 0 hypos , doc (showString "]") , prt 0 cid , prt 0 exps])
|
||||
|
||||
|
||||
instance Print Exp where
|
||||
prt i e = case e of
|
||||
DTr cids atom exps -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "(") , prt 0 cids , doc (showString ")") , prt 0 atom , prt 0 exps , doc (showString "]")])
|
||||
EEq equations -> prPrec i 0 (concatD [doc (showString "{") , prt 0 equations , 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 n -> prPrec i 0 (concatD [doc (showString "?") , prt 0 n])
|
||||
AV cid -> prPrec i 0 (concatD [doc (showString "$") , prt 0 cid])
|
||||
|
||||
|
||||
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 ")")])
|
||||
TM -> prPrec i 0 (concatD [doc (showString "?")])
|
||||
RP term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term , doc (showString ")")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print 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])
|
||||
|
||||
instance Print Hypo where
|
||||
prt i e = case e of
|
||||
Hyp cid type' -> prPrec i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type'])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print Equation where
|
||||
prt i e = case e of
|
||||
Equ exps exp -> prPrec i 0 (concatD [prt 0 exps , doc (showString "->") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module GF.GFCC.Raw.ConvertGFCC where
|
||||
module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where
|
||||
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw
|
||||
@@ -7,9 +7,9 @@ import Data.Map
|
||||
|
||||
-- convert parsed grammar to internal GFCC
|
||||
|
||||
mkGFCC :: Grammar -> GFCC
|
||||
mkGFCC (Grm [
|
||||
App (CId "abstract") [AId a],
|
||||
toGFCC :: Grammar -> GFCC
|
||||
toGFCC (Grm [
|
||||
AId a,
|
||||
App (CId "concrete") cs,
|
||||
App (CId "flags") gfs,
|
||||
ab@(
|
||||
@@ -37,8 +37,7 @@ mkGFCC (Grm [
|
||||
}
|
||||
where
|
||||
mkCnc (
|
||||
App (CId "concrete") [
|
||||
AId lang,
|
||||
App lang [
|
||||
App (CId "flags") fls,
|
||||
App (CId "lin") ls,
|
||||
App (CId "oper") ops,
|
||||
@@ -72,7 +71,9 @@ toHypo e = case e of
|
||||
toExp :: RExp -> Exp
|
||||
toExp e = case e of
|
||||
App fun [App (CId "abs") xs, App (CId "arg") exps] ->
|
||||
DTr [x | AId x <- xs] (AC fun) (lmap toExp exps)
|
||||
DTr [x | AId x <- xs] (AC fun) (lmap toExp exps)
|
||||
App (CId "Eq") _ -> EEq [] ----
|
||||
AMet -> DTr [] (AM 0) []
|
||||
_ -> error $ "exp " ++ show e
|
||||
|
||||
toTerm :: RExp -> Term
|
||||
@@ -90,29 +91,69 @@ toTerm e = case e of
|
||||
AStr s -> K (KS s) ----
|
||||
_ -> error $ "term " ++ show e
|
||||
|
||||
------------------------------
|
||||
--- from internal to parser --
|
||||
------------------------------
|
||||
|
||||
{-
|
||||
-- convert internal GFCC and pretty-print it
|
||||
|
||||
printGFCC :: GFCC -> String
|
||||
printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm
|
||||
(absname gfcc)
|
||||
(cncnames gfcc)
|
||||
[Flg f v | (f,v) <- assocs (gflags gfcc)]
|
||||
(Abs
|
||||
[Flg f v | (f,v) <- assocs (aflags (abstract gfcc))]
|
||||
[Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))]
|
||||
[Cat f v | (f,v) <- assocs (cats (abstract gfcc))]
|
||||
)
|
||||
[fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)]
|
||||
fromGFCC :: GFCC -> Grammar
|
||||
fromGFCC gfcc0 = Grm [
|
||||
AId (absname gfcc),
|
||||
app "concrete" (lmap AId (cncnames gfcc)),
|
||||
app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc)],
|
||||
app "abstract" [
|
||||
app "flags" [App f [AStr v] | (f,v) <- toList (aflags agfcc)],
|
||||
app "fun" [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
|
||||
app "cat" [App f (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
|
||||
],
|
||||
app "concrete" [App lang (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
|
||||
]
|
||||
where
|
||||
fromCnc lang cnc = Cnc lang
|
||||
[Flg f v | (f,v) <- assocs (cflags cnc)]
|
||||
[Lin f v | (f,v) <- assocs (lins cnc)]
|
||||
[Lin f v | (f,v) <- assocs (opers cnc)]
|
||||
[Lin f v | (f,v) <- assocs (lincats cnc)]
|
||||
[Lin f v | (f,v) <- assocs (lindefs cnc)]
|
||||
[Lin f v | (f,v) <- assocs (printnames cnc)]
|
||||
[Lin f v | (f,v) <- assocs (paramlincats cnc)]
|
||||
gfcc = utf8GFCC gfcc0
|
||||
-}
|
||||
gfcc = utf8GFCC gfcc0
|
||||
app s = App (CId s)
|
||||
agfcc = abstract gfcc
|
||||
fromConcrete cnc = [
|
||||
app "flags" [App f [AStr v] | (f,v) <- toList (cflags cnc)],
|
||||
app "lin" [App f [fromTerm v] | (f,v) <- toList (lins cnc)],
|
||||
app "oper" [App f [fromTerm v] | (f,v) <- toList (opers cnc)],
|
||||
app "lincat" [App f [fromTerm v] | (f,v) <- toList (lincats cnc)],
|
||||
app "lindef" [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)],
|
||||
app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)],
|
||||
app "param" [App f [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
|
||||
]
|
||||
|
||||
fromType :: Type -> RExp
|
||||
fromType e = case e of
|
||||
DTyp hypos cat exps ->
|
||||
App cat [
|
||||
App (CId "hypo") (lmap fromHypo hypos),
|
||||
App (CId "arg") (lmap fromExp exps)]
|
||||
|
||||
fromHypo :: Hypo -> RExp
|
||||
fromHypo e = case e of
|
||||
Hyp x typ -> App x [fromType typ]
|
||||
|
||||
fromExp :: Exp -> RExp
|
||||
fromExp e = case e of
|
||||
DTr xs (AC fun) exps ->
|
||||
App fun [App (CId "abs") (lmap AId xs), App (CId "arg") (lmap fromExp exps)]
|
||||
DTr xs (AM _) exps -> AMet ----
|
||||
EEq _ -> App (CId "Eq") [] ----
|
||||
_ -> error $ "exp " ++ show e
|
||||
|
||||
fromTerm :: Term -> RExp
|
||||
fromTerm e = case e of
|
||||
R es -> app "R" (lmap fromTerm es)
|
||||
S es -> app "S" (lmap fromTerm es)
|
||||
FV es -> app "FV" (lmap fromTerm es)
|
||||
P e v -> app "P" [fromTerm e, fromTerm v]
|
||||
RP e v -> app "RP" [fromTerm e, fromTerm v] ----
|
||||
W s v -> app "W" [AStr s, fromTerm v]
|
||||
C i -> AInt (toInteger i)
|
||||
TM -> AMet
|
||||
F f -> AId f
|
||||
V i -> App (CId "A") [AInt (toInteger i)]
|
||||
K (KS s) -> AStr s ----
|
||||
K (KP d vs) -> app "FV" (str d : [str v | Var v _ <- vs]) ----
|
||||
where
|
||||
app = App . CId
|
||||
str v = app "S" (lmap AStr v)
|
||||
|
||||
@@ -8,8 +8,8 @@ module GF.GFCC.ShowLinearize (
|
||||
import GF.GFCC.Linearize
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.PrintGFCC ----
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
--import GF.GFCC.PrintGFCC ----
|
||||
|
||||
import GF.Data.Operations
|
||||
import Data.List
|
||||
@@ -46,7 +46,7 @@ mkRecord typ trm = case (typ,trm) of
|
||||
(_,W s (R ts)) -> mkRecord typ (R [K (KS (s ++ u)) | K (KS u) <- ts])
|
||||
(FV ps, C i) -> RCon $ str $ ps !! i
|
||||
(S [], _) -> RS $ realize trm
|
||||
_ -> RS $ printTree trm
|
||||
_ -> RS $ show trm ---- printTree trm
|
||||
where
|
||||
str = realize
|
||||
|
||||
@@ -82,6 +82,6 @@ recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where
|
||||
|
||||
-- show GFCC term
|
||||
termLinearize :: GFCC -> CId -> Exp -> String
|
||||
termLinearize gfcc lang = printTree . linExp gfcc lang
|
||||
termLinearize gfcc lang = show . linExp gfcc lang
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user