module PGF(
PGF,
readPGF,
CId, mkCId, wildCId,
showCId, readCId,
Language,
showLanguage, readLanguage,
languages, abstractName, languageCode,
Type, Hypo,
showType, readType,
mkType, mkHypo, mkDepHypo, mkImplHypo,
categories, startCat,
functions, functionType,
Tree,
Expr,
showExpr, readExpr,
mkApp, unApp,
mkStr, unStr,
mkInt, unInt,
mkDouble, unDouble,
mkMeta, isMeta,
linearize, linearizeAllLang, linearizeAll,
groupResults,
showPrintName,
parse, parseWithRecovery, parseAllLang, parseAll,
PGF.compute, paraphrase,
checkType, checkExpr, inferExpr,
TcError(..), ppTcError,
complete,
Parse.ParseState,
Parse.initState, Parse.nextState, Parse.getCompletions, Parse.recoveryStates, Parse.extractTrees,
generateRandom, generateAll, generateAllDepth,
generateRandomFrom,
Lemma, Analysis, Morpho,
lookupMorpho, buildMorpho, fullFormLexicon,
graphvizAbstractTree,
graphvizParseTree,
graphvizDependencyTree,
graphvizAlignment,
browse
) where
import PGF.CId
import PGF.Linearize
import PGF.Generate
import PGF.TypeCheck
import PGF.Paraphrase
import PGF.VisualizeTree
import PGF.Macros
import PGF.Expr (Tree)
import PGF.Morphology
import PGF.Data
import PGF.Binary
import qualified PGF.Parse as Parse
import GF.Data.Utilities (replace)
import Data.Char
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Maybe
import Data.Binary
import Data.List(mapAccumL)
import System.Random (newStdGen)
import Control.Monad
import Text.PrettyPrint
readPGF :: FilePath -> IO PGF
linearize :: PGF -> Language -> Tree -> String
parse :: PGF -> Language -> Type -> String -> [Tree]
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> [Tree]
linearizeAll :: PGF -> Tree -> [String]
linearizeAllLang :: PGF -> Tree -> [(Language,String)]
parseAll :: PGF -> Type -> String -> [[Tree]]
parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
generateAll :: PGF -> Type -> [Expr]
generateRandom :: PGF -> Type -> IO [Expr]
generateAllDepth :: Maybe Expr -> PGF -> Type -> Maybe Int -> [Expr]
languages :: PGF -> [Language]
languageCode :: PGF -> Language -> Maybe String
abstractName :: PGF -> Language
categories :: PGF -> [CId]
startCat :: PGF -> Type
functions :: PGF -> [CId]
functionType :: PGF -> CId -> Maybe Type
complete :: PGF -> Language -> Type -> String
-> [String]
readPGF f = decodeFile f
linearize pgf lang = concat . take 1 . PGF.Linearize.linearizes pgf lang
parse pgf lang typ s =
case Map.lookup lang (concretes pgf) of
Just cnc -> Parse.parse pgf lang typ (words s)
Nothing -> error ("Unknown language: " ++ showCId lang)
parseWithRecovery pgf lang typ open_typs s = Parse.parseWithRecovery pgf lang typ open_typs (words s)
linearizeAll mgr = map snd . linearizeAllLang mgr
linearizeAllLang mgr t =
[(lang,PGF.linearize mgr lang t) | lang <- languages mgr]
groupResults :: [[(Language,String)]] -> [(Language,[String])]
groupResults = Map.toList . foldr more Map.empty . start . concat
where
start ls = [(l,[s]) | (l,s) <- ls]
more (l,s) =
Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s
parseAll mgr typ = map snd . parseAllLang mgr typ
parseAllLang mgr typ s =
[(lang,ts) | lang <- languages mgr, let ts = parse mgr lang typ s, not (null ts)]
generateRandom pgf cat = do
gen <- newStdGen
return $ genRandom gen pgf cat
generateAll pgf cat = generate pgf cat Nothing
generateAllDepth mex pgf cat = generateAllFrom mex pgf cat
abstractName pgf = absname pgf
languages pgf = Map.keys (concretes pgf)
languageCode pgf lang =
case lookConcrFlag pgf lang (mkCId "language") of
Just (LStr s) -> Just (replace '_' '-' s)
_ -> Nothing
categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
startCat pgf = DTyp [] (lookStartCat pgf) []
functions pgf = Map.keys (funs (abstract pgf))
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
Just (ty,_,_) -> Just ty
Nothing -> Nothing
complete pgf from typ input =
let (ws,prefix) = tokensAndPrefix input
state0 = Parse.initState pgf from typ
in case loop state0 ws of
Nothing -> []
Just state ->
(if null prefix && not (null (Parse.extractTrees state typ)) then [unwords ws ++ " "] else [])
++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Parse.getCompletions state prefix)]
where
tokensAndPrefix :: String -> ([String],String)
tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "")
| null ws = ([],"")
| otherwise = (init ws, last ws)
where ws = words s
loop ps [] = Just ps
loop ps (t:ts) = case Parse.nextState ps t of
Left es -> Nothing
Right ps -> loop ps ts
compute :: PGF -> Expr -> Expr
compute pgf = PGF.Data.normalForm (funs (abstract pgf),const Nothing) 0 []
browse :: PGF -> CId -> Maybe (String,[CId],[CId])
browse pgf id = fmap (\def -> (def,producers,consumers)) definition
where
definition = case Map.lookup id (funs (abstract pgf)) of
Just (ty,_,Just eqs) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs
then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts
in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
Just (ty,_,Nothing ) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just (hyps,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
Nothing -> Nothing
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
where
accum f (ty,_,_) (plist,clist) =
let !plist' = if id `elem` ps then f : plist else plist
!clist' = if id `elem` cs then f : clist else clist
in (plist',clist')
where
(ps,cs) = tyIds ty
tyIds (DTyp hyps cat es) = (foldr expIds (cat:concat css) es,concat pss)
where
(pss,css) = unzip [tyIds ty | (_,_,ty) <- hyps]
expIds (EAbs _ _ e) ids = expIds e ids
expIds (EApp e1 e2) ids = expIds e1 (expIds e2 ids)
expIds (EFun id) ids = id : ids
expIds (ETyped e _) ids = expIds e ids
expIds _ ids = ids