summaryrefslogtreecommitdiff
path: root/src-3.0/PGF/Macros.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src-3.0/PGF/Macros.hs')
-rw-r--r--src-3.0/PGF/Macros.hs139
1 files changed, 0 insertions, 139 deletions
diff --git a/src-3.0/PGF/Macros.hs b/src-3.0/PGF/Macros.hs
deleted file mode 100644
index bb5e8188b..000000000
--- a/src-3.0/PGF/Macros.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-module PGF.Macros where
-
-import PGF.CId
-import PGF.Data
-import Control.Monad
-import qualified Data.Map as Map
-import qualified Data.Array as Array
-import Data.Maybe
-import Data.List
-
--- operations for manipulating PGF grammars and objects
-
-lookLin :: PGF -> CId -> CId -> Term
-lookLin pgf lang fun =
- lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes pgf
-
-lookOper :: PGF -> CId -> CId -> Term
-lookOper pgf lang fun =
- lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes pgf
-
-lookLincat :: PGF -> CId -> CId -> Term
-lookLincat pgf lang fun =
- lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes pgf
-
-lookParamLincat :: PGF -> CId -> CId -> Term
-lookParamLincat pgf lang fun =
- lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes pgf
-
-lookPrintName :: PGF -> CId -> CId -> Term
-lookPrintName pgf lang fun =
- lookMap tm0 fun $ printnames $ lookMap (error "no lang") lang $ concretes pgf
-
-lookType :: PGF -> CId -> Type
-lookType pgf f =
- fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf))
-
-lookValCat :: PGF -> CId -> CId
-lookValCat pgf = valCat . lookType pgf
-
-lookParser :: PGF -> CId -> Maybe ParserInfo
-lookParser pgf lang = Map.lookup lang (concretes pgf) >>= parser
-
-lookFCFG :: PGF -> CId -> Maybe FGrammar
-lookFCFG pgf lang = fmap toFGrammar $ lookParser pgf lang
- where
- toFGrammar :: ParserInfo -> FGrammar
- toFGrammar pinfo = (Array.elems (allRules pinfo), startupCats pinfo)
-
-lookStartCat :: PGF -> String
-lookStartCat pgf = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
- [gflags pgf, aflags (abstract pgf)]
-
-lookGlobalFlag :: PGF -> CId -> String
-lookGlobalFlag pgf f =
- lookMap "?" f (gflags pgf)
-
-lookAbsFlag :: PGF -> CId -> String
-lookAbsFlag pgf f =
- lookMap "?" f (aflags (abstract pgf))
-
-lookConcr :: PGF -> CId -> Concr
-lookConcr pgf cnc =
- lookMap (error $ "Missing concrete syntax: " ++ prCId cnc) cnc $ concretes pgf
-
-lookConcrFlag :: PGF -> CId -> CId -> Maybe String
-lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
-
-functionsToCat :: PGF -> CId -> [(CId,Type)]
-functionsToCat pgf cat =
- [(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract pgf]]
- where
- fs = lookMap [] cat $ catfuns $ abstract pgf
-
-missingLins :: PGF -> CId -> [CId]
-missingLins pgf lang = [c | c <- fs, not (hasl c)] where
- fs = Map.keys $ funs $ abstract pgf
- hasl = hasLin pgf lang
-
-hasLin :: PGF -> CId -> CId -> Bool
-hasLin pgf lang f = Map.member f $ lins $ lookConcr pgf lang
-
-restrictPGF :: (CId -> Bool) -> PGF -> PGF
-restrictPGF cond pgf = pgf {
- abstract = abstr {
- funs = restrict $ funs $ abstr,
- cats = restrict $ cats $ abstr
- }
- } ---- restrict concrs also, might be needed
- where
- restrict = Map.filterWithKey (\c _ -> cond c)
- abstr = abstract pgf
-
-depth :: Tree -> Int
-depth (Abs _ t) = depth t
-depth (Fun _ ts) = maximum (0:map depth ts) + 1
-depth _ = 1
-
-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
-
-primNotion :: Expr
-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 = fromMaybe d $ Map.lookup c m
-
---- from Operations
-combinations :: [[a]] -> [[a]]
-combinations t = case t of
- [] -> [[]]
- aa:uu -> [a:u | a <- aa, u <- combinations uu]
-
-