1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
module GF.GFCC.Macros where
import GF.GFCC.CId
import GF.GFCC.DataGFCC
import GF.Infra.PrintClass
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Array as Array
import Data.Maybe
import Data.List
-- operations for manipulating GFCC grammars and objects
lookLin :: GFCC -> CId -> CId -> Term
lookLin gfcc lang fun =
lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes gfcc
lookOper :: GFCC -> CId -> CId -> Term
lookOper gfcc lang fun =
lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes gfcc
lookLincat :: GFCC -> CId -> CId -> Term
lookLincat gfcc lang fun =
lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc
lookParamLincat :: GFCC -> CId -> CId -> Term
lookParamLincat gfcc lang fun =
lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes gfcc
lookType :: GFCC -> CId -> Type
lookType gfcc f =
fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc))
lookParser :: GFCC -> CId -> Maybe ParserInfo
lookParser gfcc lang = parser $ lookMap (error "no lang") lang $ concretes gfcc
lookFCFG :: GFCC -> CId -> Maybe FGrammar
lookFCFG gfcc lang = fmap toFGrammar $ lookParser gfcc lang
where
toFGrammar :: ParserInfo -> FGrammar
toFGrammar pinfo = (Array.elems (allRules pinfo), startupCats pinfo)
lookStartCat :: GFCC -> String
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
[gflags gfcc, aflags (abstract gfcc)]
lookGlobalFlag :: GFCC -> CId -> String
lookGlobalFlag gfcc f =
lookMap "?" f (gflags gfcc)
lookAbsFlag :: GFCC -> CId -> String
lookAbsFlag gfcc f =
lookMap "?" f (aflags (abstract gfcc))
lookCncFlag :: GFCC -> CId -> CId -> String
lookCncFlag gfcc lang f =
lookMap "?" f $ cflags $ lookMap (error "no lang") lang $ concretes gfcc
functionsToCat :: GFCC -> CId -> [(CId,Type)]
functionsToCat gfcc cat =
[(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract gfcc]]
where
fs = lookMap [] cat $ catfuns $ abstract gfcc
depth :: Exp -> Int
depth tr = case tr of
DTr _ _ [] -> 1
DTr _ _ ts -> maximum (map depth ts) + 1
tree :: Atom -> [Exp] -> Exp
tree = DTr []
cftype :: [CId] -> CId -> Type
cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val []
catSkeleton :: Type -> ([CId],CId)
catSkeleton ty = case ty of
DTyp hyps val _ -> ([valCat ty | Hyp _ ty <- hyps],val)
typeSkeleton :: Type -> ([(Int,CId)],CId)
typeSkeleton ty = case ty of
DTyp hyps val _ -> ([(contextLength ty, valCat ty) | Hyp _ ty <- hyps],val)
valCat :: Type -> CId
valCat ty = case ty of
DTyp _ val _ -> val
contextLength :: Type -> Int
contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
exp0 :: Exp
exp0 = tree (AM 0) []
primNotion :: Exp
primNotion = EEq []
term0 :: CId -> Term
term0 = TM . prCId
tm0 :: Term
tm0 = TM "?"
kks :: String -> Term
kks = K . KS
-- lookup with default value
lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a
lookMap d c m = maybe d id $ Map.lookup c m
--- from Operations
combinations :: [[a]] -> [[a]]
combinations t = case t of
[] -> [[]]
aa:uu -> [a:u | a <- aa, u <- combinations uu]
|
