msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

remove the old Haskell runtime

Browse Source
This commit is contained in:
krangelov
2019-09-19 22:40:40 +02:00
parent acb70ccc1b
commit b3c07d45b9
41 changed files with 333 additions and 6353 deletions
Download Patch File Download Diff File Expand all files Collapse all files

274
src/runtime/haskell-bind/PGF.hs
View File

@@ -1,274 +0,0 @@
module PGF (PGF, readPGF, showPGF,
abstractName,
CId, mkCId, wildCId, showCId, readCId,
categories, categoryContext, categoryProbability,
functions, functionsByCat, functionType, functionIsDataCon, browse,
PGF2.Expr,Tree,showExpr,PGF2.readExpr,pExpr,pIdent,
mkAbs,unAbs,
mkApp,unApp,unapply,
PGF2.mkStr,PGF2.unStr,
PGF2.mkInt,PGF2.unInt,
PGF2.mkFloat,PGF2.unFloat,
PGF2.mkMeta,PGF2.unMeta,
PGF2.exprSize, exprFunctions,PGF2.exprSubstitute,
compute,
rankTreesByProbs,treeProbability,
TcError, ppTcError, inferExpr, checkType,
PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType,
mkType, unType,
Token,
Language, readLanguage, showLanguage,
languages, startCat, languageCode,
linearize, bracketedLinearize, tabularLinearizes, showBracketedString,
ParseOutput(..), parse, parse_, complete,
PGF2.BracketedString(..), PGF2.flattenBracketedString,
hasLinearization,
showPrintName,
Morpho, buildMorpho,
lookupMorpho, isInMorpho, morphoMissing, morphoKnown, fullFormLexicon,
Labels, getDepLabels, CncLabels, getCncDepLabels,
generateAllDepth, generateRandom, generateRandomFrom, generateRandomDepth, generateRandomFromDepth,
generateFromDepth,
PGF2.GraphvizOptions(..),
graphvizAbstractTree, graphvizParseTree, graphvizAlignment, graphvizDependencyTree, graphvizParseTreeDep,
-- * Tries
ATree(..),Trie(..),toATree,toTrie,
readProbabilitiesFromFile,
groupResults, conlls2latexDoc, gizaAlignment
) where
import PGF.Internal
import qualified PGF2
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP
import Data.List(sortBy)
import Text.PrettyPrint(text)
import Data.Char(isDigit)
readPGF = PGF2.readPGF
showPGF gr = PGF2.showPGF gr
readLanguage = readCId
showLanguage (CId s) = s
startCat = PGF2.startCat
languageCode pgf lang = Just (PGF2.languageCode (lookConcr pgf lang))
abstractName gr = CId (PGF2.abstractName gr)
categories gr = map CId (PGF2.categories gr)
categoryContext gr (CId c) = PGF2.categoryContext gr c
categoryProbability gr (CId c) = PGF2.categoryProbability gr c
functions gr = map CId (PGF2.functions gr)
functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c)
functionType gr (CId f) = PGF2.functionType gr f
functionIsDataCon gr (CId f) = PGF2.functionIsDataCon gr f
type Tree = PGF2.Expr
type Labels = Map.Map CId [String]
type CncLabels = [(String, String -> Maybe (String -> String,String,String))]
mkCId x = CId x
wildCId = CId "_"
showCId (CId x) = x
readCId s = Just (CId s)
showExpr xs e = PGF2.showExpr [x | CId x <- xs] e
pExpr = RP.readS_to_P PGF2.pExpr
pIdent = RP.readS_to_P PGF2.pIdent
mkAbs bind_type (CId var) e = PGF2.mkAbs bind_type var e
unAbs e = case PGF2.unAbs e of
Just (bind_type, var, e) -> Just (bind_type, CId var, e)
Nothing -> Nothing
mkApp (CId f) es = PGF2.mkApp f es
unApp e = case PGF2.unApp e of
Just (f,es) -> Just (CId f,es)
Nothing -> Nothing
unapply = PGF2.unapply
instance Read PGF2.Expr where
readsPrec _ s = case PGF2.readExpr s of
Just e -> [(e,"")]
Nothing -> []
showType xs ty = PGF2.showType [x | CId x <- xs] ty
showContext xs hypos = PGF2.showContext [x | CId x <- xs] hypos
mkType hypos (CId var) es = PGF2.mkType [(bt,var,ty) | (bt,CId var,ty) <- hypos] var es
unType ty = case PGF2.unType ty of
(hypos,var,es) -> ([(bt,CId var,ty) | (bt,var,ty) <- hypos],CId var,es)
linearize pgf lang e = PGF2.linearize (lookConcr pgf lang) e
bracketedLinearize pgf lang e = PGF2.bracketedLinearize (lookConcr pgf lang) e
tabularLinearizes pgf lang e = [PGF2.tabularLinearize (lookConcr pgf lang) e]
showBracketedString = PGF2.showBracketedString
type TcError = String
-- | This data type encodes the different outcomes which you could get from the parser.
data ParseOutput
= ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed.
| TypeError [(FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct.
-- The forest id ('FId') points to the bracketed string from the parser
-- where the type checking failed. More than one error is returned
-- if there are many analizes for some phrase but they all are not type correct.
| ParseOk [Tree] -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees.
-- The list should be non-empty.
| ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced
parse pgf lang cat s =
case PGF2.parse (lookConcr pgf lang) cat s of
PGF2.ParseOk ts -> map fst ts
_ -> []
parse_ pgf lang cat dp s =
case PGF2.parse (lookConcr pgf lang) cat s of
PGF2.ParseFailed pos _ -> (ParseFailed pos, PGF2.Leaf s)
PGF2.ParseOk ts -> (ParseOk (map fst ts), PGF2.Leaf s)
PGF2.ParseIncomplete -> (ParseIncomplete, PGF2.Leaf s)
complete pgf lang cat s prefix =
let compls = Map.fromListWith (++) [(tok,[CId fun]) | (tok,_,fun,_) <- PGF2.complete (lookConcr pgf lang) cat s prefix]
in (PGF2.Leaf [],s,compls)
hasLinearization pgf lang (CId f) = PGF2.hasLinearization (lookConcr pgf lang) f
ppTcError s = s
inferExpr gr e =
case PGF2.inferExpr gr e of
Right res -> Right res
Left msg -> Left (text msg)
checkType gr ty =
case PGF2.checkType gr ty of
Right res -> Right res
Left msg -> Left (text msg)
showPrintName pgf lang (CId f) =
case PGF2.printName (lookConcr pgf lang) f of
Just n -> n
Nothing -> f
getDepLabels :: String -> Labels
getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
getCncDepLabels :: String -> CncLabels
getCncDepLabels = PGF2.getCncDepLabels
generateAllDepth gr ty _ = map fst (PGF2.generateAll gr ty)
generateFromDepth = error "generateFromDepth is not implemented"
generateRandom = error "generateRandom is not implemented"
generateRandomFrom = error "generateRandomFrom is not implemented"
generateRandomDepth = error "generateRandomDepth is not implemented"
generateRandomFromDepth = error "generateRandomFromDepth is not implemented"
exprFunctions e = [CId f | f <- PGF2.exprFunctions e]
compute = error "compute is not implemented"
-- | rank from highest to lowest probability
rankTreesByProbs :: PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)]
rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts]
treeProbability = PGF2.treeProbability
languages pgf = fmap CId (Map.keys (PGF2.languages pgf))
type Morpho = PGF2.Concr
buildMorpho pgf lang = lookConcr pgf lang
lookupMorpho cnc w = [(CId lemma,an) | (lemma,an,_) <- PGF2.lookupMorpho cnc w]
isInMorpho cnc w = not (null (PGF2.lookupMorpho cnc w))
fullFormLexicon cnc = [(w, [(CId fun,an) | (fun,an,_) <- analyses]) | (w, analyses) <- PGF2.fullFormLexicon cnc]
graphvizAbstractTree pgf (funs,cats) = PGF2.graphvizAbstractTree pgf PGF2.graphvizDefaults{PGF2.noFun=not funs,PGF2.noCat=not cats}
graphvizParseTree pgf lang = PGF2.graphvizParseTree (lookConcr pgf lang)
graphvizAlignment pgf langs = PGF2.graphvizWordAlignment (map (lookConcr pgf) langs) PGF2.graphvizDefaults
graphvizDependencyTree format debug lbls cnclbls pgf lang e =
let to_lbls' lbls = Map.fromList [(id,xs) | (CId id,xs) <- Map.toList lbls]
in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e
graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented"
browse :: PGF -> CId -> Maybe (String,[CId],[CId])
browse = error "browse is not implemented"
-- | A type for plain applicative trees
data ATree t = Other t | App CId [ATree t] deriving Show
data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show
-- ^ A type for tries of plain applicative trees
-- | Convert a 'Tree' to an 'ATree'
toATree :: Tree -> ATree Tree
toATree e = maybe (Other e) app (PGF2.unApp e)
where
app (f,es) = App (mkCId f) (map toATree es)
-- | Combine a list of trees into a trie
toTrie = combines . map ((:[]) . singleton)
where
singleton t = case t of
Other e -> Oth e
App f ts -> Ap f [map singleton ts]
combines [] = []
combines (ts:tss) = ts1:combines tss2
where
(ts1,tss2) = combines2 [] tss ts
combines2 ots [] ts1 = (ts1,reverse ots)
combines2 ots (ts2:tss) ts1 =
maybe (combines2 (ts2:ots) tss ts1) (combines2 ots tss) (combine ts1 ts2)
combine ts us = mapM combine2 (zip ts us)
where
combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us)))
combine2 _ = Nothing
readProbabilitiesFromFile :: FilePath -> IO (Map.Map CId Double)
readProbabilitiesFromFile fpath = do
s <- readFile fpath
return $ Map.fromList [(mkCId f,read p) | f:p:_ <- map words (lines s)]
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
conlls2latexDoc = error "conlls2latexDoc is not implemented"
morphoMissing :: Morpho -> [String] -> [String]
morphoMissing = morphoClassify False
morphoKnown :: Morpho -> [String] -> [String]
morphoKnown = morphoClassify True
morphoClassify :: Bool -> Morpho -> [String] -> [String]
morphoClassify k mo ws = [w | w <- ws, k /= null (lookupMorpho mo w), notLiteral w] where
notLiteral w = not (all isDigit w) ---- should be defined somewhere
gizaAlignment = error "gizaAlignment is not implemented"

163
src/runtime/haskell-bind/PGF/Internal.hs
View File

@@ -1,163 +0,0 @@
{-# LANGUAGE ImplicitParams #-}
module PGF.Internal(CId(..),Language,PGF2.PGF,
PGF2.Concr,lookConcr,
PGF2.FId,isPredefFId,
PGF2.FunId,PGF2.SeqId,PGF2.LIndex,PGF2.Token,
PGF2.Production(..),PGF2.PArg(..),PGF2.Symbol(..),PGF2.Literal(..),PGF2.BindType(..),Sequence,
globalFlags, abstrFlags, concrFlags,
concrTotalCats, concrCategories, concrProductions,
concrTotalFuns, concrFunction,
concrTotalSeqs, concrSequence,
PGF2.CodeLabel, PGF2.Instr(..), PGF2.IVal(..), PGF2.TailInfo(..),
PGF2.Builder, PGF2.B, PGF2.build,
eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo,
PGF2.AbstrInfo, newAbstr, PGF2.ConcrInfo, newConcr, newPGF,
-- * Write an in-memory PGF to a file
writePGF, writeConcr,
PGF2.fidString, PGF2.fidInt, PGF2.fidFloat, PGF2.fidVar, PGF2.fidStart,
ppFunId, ppSeqId, ppFId, ppMeta, ppLit, ppSeq,
unionPGF
) where
import qualified PGF2
import qualified PGF2.Internal as PGF2
import qualified Data.Map as Map
import PGF2.FFI(PGF(..))
import Data.Array.IArray
import Data.Array.Unboxed
import Text.PrettyPrint
newtype CId = CId String deriving (Show,Read,Eq,Ord)
type Language = CId
lookConcr (PGF _ langs _) (CId lang) =
case Map.lookup lang langs of
Just cnc -> cnc
Nothing -> error "Unknown language"
globalFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.globalFlags pgf]
abstrFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.abstrFlags pgf]
concrFlags concr = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.concrFlags concr]
concrTotalCats = PGF2.concrTotalCats
concrCategories :: PGF2.Concr -> [(CId,PGF2.FId,PGF2.FId,[String])]
concrCategories c = [(CId cat,start,end,lbls) | (cat,start,end,lbls) <- PGF2.concrCategories c]
concrProductions :: PGF2.Concr -> PGF2.FId -> [PGF2.Production]
concrProductions = PGF2.concrProductions
concrTotalFuns = PGF2.concrTotalFuns
concrFunction :: PGF2.Concr -> PGF2.FunId -> (CId,[PGF2.SeqId])
concrFunction c funid =
let (fun,seqids) = PGF2.concrFunction c funid
in (CId fun,seqids)
concrTotalSeqs :: PGF2.Concr -> PGF2.SeqId
concrTotalSeqs = PGF2.concrTotalSeqs
concrSequence = PGF2.concrSequence
isPredefFId = PGF2.isPredefFId
type Sequence = [PGF2.Symbol]
eAbs :: (?builder :: PGF2.Builder s) => PGF2.BindType -> CId -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
eAbs bind_type (CId var) body = PGF2.eAbs bind_type var body
eApp :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
eApp = PGF2.eApp
eMeta :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
eMeta = PGF2.eMeta
eFun (CId fun) = PGF2.eFun fun
eVar :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
eVar = PGF2.eVar
eLit :: (?builder :: PGF2.Builder s) => PGF2.Literal -> PGF2.B s PGF2.Expr
eLit = PGF2.eLit
eTyped :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Type -> PGF2.B s PGF2.Expr
eTyped = PGF2.eTyped
eImplArg :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
eImplArg = PGF2.eImplArg
dTyp :: (?builder :: PGF2.Builder s) => [PGF2.B s (PGF2.BindType,String,PGF2.Type)] -> CId -> [PGF2.B s PGF2.Expr] -> PGF2.B s PGF2.Type
dTyp hypos (CId cat) es = PGF2.dTyp hypos cat es
hypo bind_type (CId var) ty = PGF2.hypo bind_type var ty
newAbstr flags cats funs = PGF2.newAbstr [(flag,lit) | (CId flag,lit) <- flags]
[(cat,hypos,prob) | (CId cat,hypos,prob) <- cats]
[(fun,ty,arity,prob) | (CId fun,ty,arity,prob) <- funs]
newConcr abs flags printnames lindefs linrefs prods cncfuns seqs cnccats total_ccats =
PGF2.newConcr abs [(flag,lit) | (CId flag,lit) <- flags]
[(id,name) | (CId id,name) <- printnames]
lindefs linrefs
prods
[(fun,seq_ids) | (CId fun,seq_ids) <- cncfuns]
seqs
[(cat,start,end,labels) | (CId cat,start,end,labels) <- cnccats]
total_ccats
newPGF flags (CId name) abstr concrs =
PGF2.newPGF [(flag,lit) | (CId flag,lit) <- flags]
name
abstr
[(name,concr) | (CId name,concr) <- concrs]
writePGF = PGF2.writePGF
writeConcr fpath pgf lang = PGF2.writeConcr fpath (lookConcr pgf lang)
ppFunId funid = char 'F' <> int funid
ppSeqId seqid = char 'S' <> int seqid
ppFId fid
| fid == PGF2.fidString = text "CString"
| fid == PGF2.fidInt = text "CInt"
| fid == PGF2.fidFloat = text "CFloat"
| fid == PGF2.fidVar = text "CVar"
| fid == PGF2.fidStart = text "CStart"
| otherwise = char 'C' <> int fid
ppMeta :: Int -> Doc
ppMeta n
| n == 0 = char '?'
| otherwise = char '?' <> int n
ppLit (PGF2.LStr s) = text (show s)
ppLit (PGF2.LInt n) = int n
ppLit (PGF2.LFlt d) = double d
ppSeq (seqid,seq) =
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol seq)
ppSymbol (PGF2.SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (PGF2.SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
ppSymbol (PGF2.SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
ppSymbol (PGF2.SymKS t) = doubleQuotes (text t)
ppSymbol PGF2.SymNE = text "nonExist"
ppSymbol PGF2.SymBIND = text "BIND"
ppSymbol PGF2.SymSOFT_BIND = text "SOFT_BIND"
ppSymbol PGF2.SymSOFT_SPACE= text "SOFT_SPACE"
ppSymbol PGF2.SymCAPIT = text "CAPIT"
ppSymbol PGF2.SymALL_CAPIT = text "ALL_CAPIT"
ppSymbol (PGF2.SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
unionPGF = PGF2.unionPGF

544
src/runtime/haskell/PGF.hs
View File

@@ -1,394 +1,219 @@
{-# LANGUAGE BangPatterns #-}
-------------------------------------------------
-- |
-- Module : PGF
-- Maintainer : Krasimir Angelov
-- Stability : stable
-- Portability : portable
--
-- This module is an Application Programming Interface to
-- load and interpret grammars compiled in Portable Grammar Format (PGF).
-- The PGF format is produced as a final output from the GF compiler.
-- The API is meant to be used for embedding GF grammars in Haskell
-- programs
-------------------------------------------------
module PGF (PGF, readPGF, showPGF,
abstractName,
module PGF(
-- * PGF
PGF,
readPGF, showPGF,
CId, mkCId, wildCId, showCId, readCId,
categories, categoryContext, categoryProbability,
functions, functionsByCat, functionType, functionIsDataCon, browse,
-- * Identifiers
CId, mkCId, wildCId,
showCId, readCId,
-- extra
ppCId, pIdent, utf8CId,
PGF2.Expr,Tree,showExpr,PGF2.readExpr,pExpr,pIdent,
mkAbs,unAbs,
mkApp,unApp,unapply,
PGF2.mkStr,PGF2.unStr,
PGF2.mkInt,PGF2.unInt,
PGF2.mkFloat,PGF2.unFloat,
PGF2.mkMeta,PGF2.unMeta,
PGF2.exprSize, exprFunctions,PGF2.exprSubstitute,
compute,
rankTreesByProbs,treeProbability,
-- * Languages
Language,
showLanguage, readLanguage,
languages, abstractName, languageCode,
TcError, ppTcError, inferExpr, checkType,
-- * Types
Type, Hypo,
showType, readType,
mkType, mkHypo, mkDepHypo, mkImplHypo,
unType,
categories, categoryContext, startCat,
PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType,
mkType, unType,
-- * Functions
functions, functionsByCat, functionType, missingLins,
Token,
-- * Expressions & Trees
-- ** Tree
Tree,
Language, readLanguage, showLanguage,
languages, startCat, languageCode,
linearize, bracketedLinearize, tabularLinearizes, showBracketedString,
ParseOutput(..), parse, parse_, complete,
PGF2.BracketedString(..), PGF2.flattenBracketedString,
hasLinearization,
showPrintName,
Morpho, buildMorpho,
lookupMorpho, isInMorpho, morphoMissing, morphoKnown, fullFormLexicon,
-- ** Expr
Expr,
showExpr, readExpr,
mkAbs, unAbs,
mkApp, unApp, unapply,
mkStr, unStr,
mkInt, unInt,
mkDouble, unDouble,
mkFloat, unFloat,
mkMeta, unMeta,
exprSubstitute,
Labels, getDepLabels, CncLabels, getCncDepLabels,
-- extra
pExpr, exprSize, exprFunctions,
generateAllDepth, generateRandom, generateRandomFrom, generateRandomDepth, generateRandomFromDepth,
generateFromDepth,
-- * Operations
-- ** Linearization
linearize, linearizeAllLang, linearizeAll, bracketedLinearize, tabularLinearizes,
groupResults, -- lins of trees by language, removing duplicates
showPrintName,
BracketedString(..), FId, LIndex, Token,
Forest.showBracketedString,flattenBracketedString,
PGF2.GraphvizOptions(..),
graphvizAbstractTree, graphvizParseTree, graphvizAlignment, graphvizDependencyTree, graphvizParseTreeDep,
-- ** Parsing
parse, parseAllLang, parseAll, parse_, parseWithRecovery, complete,
-- * Tries
ATree(..),Trie(..),toATree,toTrie,
readProbabilitiesFromFile,
groupResults, conlls2latexDoc, gizaAlignment
) where
-- ** Evaluation
PGF.compute, paraphrase,
-- ** Type Checking
-- | The type checker in PGF does both type checking and renaming
-- i.e. it verifies that all identifiers are declared and it
-- distinguishes between global function or type indentifiers and
-- variable names. The type checker should always be applied on
-- expressions entered by the user i.e. those produced via functions
-- like 'readType' and 'readExpr' because otherwise unexpected results
-- could appear. All typechecking functions returns updated versions
-- of the input types or expressions because the typechecking could
-- also lead to metavariables instantiations.
checkType, checkExpr, inferExpr,
TcError(..), ppTcError,
-- ** Low level parsing API
Parse.ParseState,
Parse.initState, Parse.nextState, Parse.getCompletions, Parse.recoveryStates,
Parse.ParseInput(..), Parse.simpleParseInput, Parse.mkParseInput,
Parse.ParseOutput(..), Parse.getParseOutput,
Parse.getContinuationInfo,
-- ** Generation
-- | The PGF interpreter allows automatic generation of
-- abstract syntax expressions of a given type. Since the
-- type system of GF allows dependent types, the generation
-- is in general undecidable. In fact, the set of all type
-- signatures in the grammar is equivalent to a Turing-complete language (Prolog).
--
-- There are several generation methods which mainly differ in:
--
-- * whether the expressions are sequentially or randomly generated?
--
-- * are they generated from a template? The template is an expression
-- containing meta variables which the generator will fill in.
--
-- * is there a limit of the depth of the expression?
-- The depth can be used to limit the search space, which
-- in some cases is the only way to make the search decidable.
generateAll, generateAllDepth,
generateFrom, generateFromDepth,
generateRandom, generateRandomDepth,
generateRandomFrom, generateRandomFromDepth,
-- ** Morphological Analysis
Lemma, Analysis, Morpho,
lookupMorpho, buildMorpho, fullFormLexicon,
morphoMissing,
-- extra:
morphoKnown, isInMorpho,
-- ** Visualizations
graphvizAbstractTree,
graphvizParseTree,
graphvizParseTreeDep,
graphvizDependencyTree,
graphvizBracketedString,
graphvizAlignment,
gizaAlignment,
GraphvizOptions(..),
graphvizDefaults,
conlls2latexDoc,
-- extra:
Labels, getDepLabels,
CncLabels, getCncDepLabels,
-- * Probabilities
Probabilities,
mkProbabilities,
defaultProbabilities,
showProbabilities,
readProbabilitiesFromFile,
-- extra:
probTree, setProbabilities, rankTreesByProbs,
-- -- ** SortTop
-- forExample,
-- * Browsing
browse,
-- * Tries
ATree(..),Trie(..),toATree,toTrie
) where
import PGF.CId
import PGF.Linearize
--import PGF.SortTop
import PGF.Generate
import PGF.TypeCheck
import PGF.Paraphrase
import PGF.VisualizeTree
import PGF.Probabilistic
import PGF.Macros
import PGF.Expr (Tree)
import PGF.Morphology
import PGF.Data
import PGF.Binary()
import qualified PGF.Forest as Forest
import qualified PGF.Parse as Parse
import PGF.Utilities(replace)
import PGF.Printer
import Text.PrettyPrint
--import Data.Char
import PGF.Internal
import qualified PGF2
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
import qualified Text.ParserCombinators.ReadP as RP
import Data.List(sortBy)
import Text.PrettyPrint(text)
import Data.Char(isDigit)
---------------------------------------------------
-- Interface
---------------------------------------------------
readPGF = PGF2.readPGF
-- | Reads file in Portable Grammar Format and produces
-- 'PGF' structure. The file is usually produced with:
--
-- > $ gf -make <grammar file name>
readPGF :: FilePath -> IO PGF
showPGF gr = PGF2.showPGF gr
-- | Tries to parse the given string in the specified language
-- and to produce abstract syntax expression.
parse :: PGF -> Language -> Type -> String -> [Tree]
readLanguage = readCId
showLanguage (CId s) = s
-- | The same as 'parseAllLang' but does not return
-- the language.
parseAll :: PGF -> Type -> String -> [[Tree]]
startCat = PGF2.startCat
languageCode pgf lang = Just (PGF2.languageCode (lookConcr pgf lang))
-- | Tries to parse the given string with all available languages.
-- The returned list contains pairs of language
-- and list of abstract syntax expressions
-- (this is a list, since grammars can be ambiguous).
-- Only those languages
-- for which at least one parsing is possible are listed.
parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
abstractName gr = CId (PGF2.abstractName gr)
-- | The same as 'parse' but returns more detailed information
parse_ :: PGF -> Language -> Type -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
categories gr = map CId (PGF2.categories gr)
categoryContext gr (CId c) = PGF2.categoryContext gr c
categoryProbability gr (CId c) = PGF2.categoryProbability gr c
-- | This is an experimental function. Use it on your own risk
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
functions gr = map CId (PGF2.functions gr)
functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c)
functionType gr (CId f) = PGF2.functionType gr f
functionIsDataCon gr (CId f) = PGF2.functionIsDataCon gr f
-- | List of all languages available in the given grammar.
languages :: PGF -> [Language]
-- | Gets the RFC 4646 language tag
-- of the language which the given concrete syntax implements,
-- if this is listed in the source grammar.
-- Example language tags include @\"en\"@ for English,
-- and @\"en-UK\"@ for British English.
languageCode :: PGF -> Language -> Maybe String
-- | The abstract language name is the name of the top-level
-- abstract module
abstractName :: PGF -> Language
-- | List of all categories defined in the given grammar.
-- The categories are defined in the abstract syntax
-- with the \'cat\' keyword.
categories :: PGF -> [CId]
categoryContext :: PGF -> CId -> Maybe [Hypo]
-- | The start category is defined in the grammar with
-- the \'startcat\' flag. This is usually the sentence category
-- but it is not necessary. Despite that there is a start category
-- defined you can parse with any category. The start category
-- definition is just for convenience.
startCat :: PGF -> Type
-- | List of all functions defined in the abstract syntax
functions :: PGF -> [CId]
-- | List of all functions defined for a given category
functionsByCat :: PGF -> CId -> [CId]
-- | The type of a given function
functionType :: PGF -> CId -> Maybe Type
type Tree = PGF2.Expr
type Labels = Map.Map CId [String]
type CncLabels = [(String, String -> Maybe (String -> String,String,String))]
---------------------------------------------------
-- Implementation
---------------------------------------------------
mkCId x = CId x
wildCId = CId "_"
showCId (CId x) = x
readCId s = Just (CId s)
readPGF f = decodeFile f
showExpr xs e = PGF2.showExpr [x | CId x <- xs] e
showPGF pgf = render (ppPGF pgf)
pExpr = RP.readS_to_P PGF2.pExpr
pIdent = RP.readS_to_P PGF2.pIdent
parse pgf lang typ s =
case parse_ pgf lang typ (Just 4) s of
(Parse.ParseOk ts,_) -> ts
_ -> []
mkAbs bind_type (CId var) e = PGF2.mkAbs bind_type var e
unAbs e = case PGF2.unAbs e of
Just (bind_type, var, e) -> Just (bind_type, CId var, e)
Nothing -> Nothing
parseAll mgr typ = map snd . parseAllLang mgr typ
mkApp (CId f) es = PGF2.mkApp f es
unApp e = case PGF2.unApp e of
Just (f,es) -> Just (CId f,es)
Nothing -> Nothing
parseAllLang mgr typ s =
[(lang,ts) | lang <- languages mgr, (Parse.ParseOk ts,_) <- [parse_ mgr lang typ (Just 4) s]]
unapply = PGF2.unapply
parse_ pgf lang typ dp s =
case Map.lookup lang (concretes pgf) of
Just cnc -> Parse.parse pgf lang typ dp (words s)
Nothing -> error ("Unknown language: " ++ showCId lang)
instance Read PGF2.Expr where
readsPrec _ s = case PGF2.readExpr s of
Just e -> [(e,"")]
Nothing -> []
parseWithRecovery pgf lang typ open_typs dp s = Parse.parseWithRecovery pgf lang typ open_typs dp (words s)
showType xs ty = PGF2.showType [x | CId x <- xs] ty
showContext xs hypos = PGF2.showContext [x | CId x <- xs] hypos
complete :: PGF -> Language -> Type -> String -> String -> (BracketedString,String,Map.Map Token [CId])
complete pgf from typ input prefix =
let ws = words input
ps0 = Parse.initState pgf from typ
(ps,ws') = loop ps0 ws
bs = snd (Parse.getParseOutput ps typ Nothing)
in if not (null ws')
then (bs, unwords (if null prefix then ws' else ws'++[prefix]), Map.empty)
else (bs, prefix, fmap getFuns (Parse.getCompletions ps prefix))
where
loop ps [] = (ps,[])
loop ps (w:ws) = case Parse.nextState ps (Parse.simpleParseInput w) of
Left es -> (ps,w:ws)
Right ps -> loop ps ws
mkType hypos (CId var) es = PGF2.mkType [(bt,var,ty) | (bt,CId var,ty) <- hypos] var es
unType ty = case PGF2.unType ty of
(hypos,var,es) -> ([(bt,CId var,ty) | (bt,var,ty) <- hypos],CId var,es)
getFuns ps = [cid | (funid,cid,seq) <- snd . head $ Map.toList contInfo]
where
contInfo = Parse.getContinuationInfo ps
linearize pgf lang e = PGF2.linearize (lookConcr pgf lang) e
bracketedLinearize pgf lang e = PGF2.bracketedLinearize (lookConcr pgf lang) e
tabularLinearizes pgf lang e = [PGF2.tabularLinearize (lookConcr pgf lang) e]
showBracketedString = PGF2.showBracketedString
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
type TcError = String
abstractName pgf = absname pgf
-- | This data type encodes the different outcomes which you could get from the parser.
data ParseOutput
= ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed.
| TypeError [(FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct.
-- The forest id ('FId') points to the bracketed string from the parser
-- where the type checking failed. More than one error is returned
-- if there are many analizes for some phrase but they all are not type correct.
| ParseOk [Tree] -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees.
-- The list should be non-empty.
| ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced
languages pgf = Map.keys (concretes pgf)
parse pgf lang cat s =
case PGF2.parse (lookConcr pgf lang) cat s of
PGF2.ParseOk ts -> map fst ts
_ -> []
languageCode pgf lang =
case lookConcrFlag pgf lang (mkCId "language") of
Just (LStr s) -> Just (replace '_' '-' s)
_ -> Nothing
parse_ pgf lang cat dp s =
case PGF2.parse (lookConcr pgf lang) cat s of
PGF2.ParseFailed pos _ -> (ParseFailed pos, PGF2.Leaf s)
PGF2.ParseOk ts -> (ParseOk (map fst ts), PGF2.Leaf s)
PGF2.ParseIncomplete -> (ParseIncomplete, PGF2.Leaf s)
categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
complete pgf lang cat s prefix =
let compls = Map.fromListWith (++) [(tok,[CId fun]) | (tok,_,fun,_) <- PGF2.complete (lookConcr pgf lang) cat s prefix]
in (PGF2.Leaf [],s,compls)
categoryContext pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
Just (hypos,_,_) -> Just hypos
Nothing -> Nothing
hasLinearization pgf lang (CId f) = PGF2.hasLinearization (lookConcr pgf lang) f
startCat pgf = DTyp [] (lookStartCat pgf) []
ppTcError s = s
functions pgf = Map.keys (funs (abstract pgf))
inferExpr gr e =
case PGF2.inferExpr gr e of
Right res -> Right res
Left msg -> Left (text msg)
functionsByCat pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
Just (_,fns,_) -> map snd fns
Nothing -> []
checkType gr ty =
case PGF2.checkType gr ty of
Right res -> Right res
Left msg -> Left (text msg)
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
Just (ty,_,_,_) -> Just ty
Nothing -> Nothing
showPrintName pgf lang (CId f) =
case PGF2.printName (lookConcr pgf lang) f of
Just n -> n
Nothing -> f
-- | Converts an expression to normal form
compute :: PGF -> Expr -> Expr
compute pgf = PGF.Data.normalForm (funs (abstract pgf),const Nothing) 0 []
getDepLabels :: String -> Labels
getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
exprSize :: Expr -> Int
exprSize (EAbs _ _ e) = exprSize e
exprSize (EApp e1 e2) = exprSize e1 + exprSize e2
exprSize (ETyped e ty)= exprSize e
exprSize (EImplArg e) = exprSize e
exprSize _ = 1
getCncDepLabels :: String -> CncLabels
getCncDepLabels = PGF2.getCncDepLabels
exprFunctions :: Expr -> [CId]
exprFunctions (EAbs _ _ e) = exprFunctions e
exprFunctions (EApp e1 e2) = exprFunctions e1 ++ exprFunctions e2
exprFunctions (ETyped e ty)= exprFunctions e
exprFunctions (EImplArg e) = exprFunctions e
exprFunctions (EFun f) = [f]
exprFunctions _ = []
generateAllDepth gr ty _ = map fst (PGF2.generateAll gr ty)
generateFromDepth = error "generateFromDepth is not implemented"
generateRandom = error "generateRandom is not implemented"
generateRandomFrom = error "generateRandomFrom is not implemented"
generateRandomDepth = error "generateRandomDepth is not implemented"
generateRandomFromDepth = error "generateRandomFromDepth is not implemented"
--exprFunctions :: Expr -> [Fun]
exprFunctions e = [CId f | f <- PGF2.exprFunctions e]
compute = error "compute is not implemented"
-- | rank from highest to lowest probability
rankTreesByProbs :: PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)]
rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts]
treeProbability = PGF2.treeProbability
languages pgf = fmap CId (Map.keys (PGF2.languages pgf))
type Morpho = PGF2.Concr
buildMorpho pgf lang = lookConcr pgf lang
lookupMorpho cnc w = [(CId lemma,an) | (lemma,an,_) <- PGF2.lookupMorpho cnc w]
isInMorpho cnc w = not (null (PGF2.lookupMorpho cnc w))
fullFormLexicon cnc = [(w, [(CId fun,an) | (fun,an,_) <- analyses]) | (w, analyses) <- PGF2.fullFormLexicon cnc]
graphvizAbstractTree pgf (funs,cats) = PGF2.graphvizAbstractTree pgf PGF2.graphvizDefaults{PGF2.noFun=not funs,PGF2.noCat=not cats}
graphvizParseTree pgf lang = PGF2.graphvizParseTree (lookConcr pgf lang)
graphvizAlignment pgf langs = PGF2.graphvizWordAlignment (map (lookConcr pgf) langs) PGF2.graphvizDefaults
graphvizDependencyTree format debug lbls cnclbls pgf lang e =
let to_lbls' lbls = Map.fromList [(id,xs) | (CId id,xs) <- Map.toList lbls]
in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e
graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented"
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.foldrWithKey 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
browse = error "browse is not implemented"
-- | A type for plain applicative trees
data ATree t = Other t | App CId [ATree t] deriving Show
@@ -397,9 +222,9 @@ data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show
-- | Convert a 'Tree' to an 'ATree'
toATree :: Tree -> ATree Tree
toATree e = maybe (Other e) app (unApp e)
toATree e = maybe (Other e) app (PGF2.unApp e)
where
app (f,es) = App f (map toATree es)
app (f,es) = App (mkCId f) (map toATree es)
-- | Combine a list of trees into a trie
toTrie = combines . map ((:[]) . singleton)
@@ -420,3 +245,30 @@ toTrie = combines . map ((:[]) . singleton)
where
combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us)))
combine2 _ = Nothing
readProbabilitiesFromFile :: FilePath -> IO (Map.Map CId Double)
readProbabilitiesFromFile fpath = do
s <- readFile fpath
return $ Map.fromList [(mkCId f,read p) | f:p:_ <- map words (lines s)]
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
conlls2latexDoc = error "conlls2latexDoc is not implemented"
morphoMissing :: Morpho -> [String] -> [String]
morphoMissing = morphoClassify False
morphoKnown :: Morpho -> [String] -> [String]
morphoKnown = morphoClassify True
morphoClassify :: Bool -> Morpho -> [String] -> [String]
morphoClassify k mo ws = [w | w <- ws, k /= null (lookupMorpho mo w), notLiteral w] where
notLiteral w = not (all isDigit w) ---- should be defined somewhere
gizaAlignment = error "gizaAlignment is not implemented"

281
src/runtime/haskell/PGF/Binary.hs
View File

@@ -1,281 +0,0 @@
module PGF.Binary(putSplitAbs) where
import PGF.CId
import PGF.Data
import PGF.Optimize
import PGF.ByteCode
import qualified PGF.OldBinary as Old
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.Array.IArray
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
--import qualified Data.Set as Set
import Control.Monad
pgfMajorVersion, pgfMinorVersion :: Word16
version@(pgfMajorVersion, pgfMinorVersion) = (2,1)
instance Binary PGF where
put pgf = do putWord16be pgfMajorVersion
putWord16be pgfMinorVersion
put (gflags pgf)
put (absname pgf, abstract pgf)
put (concretes pgf)
get = do major<- getWord16be
minor <- getWord16be
let v = (major,minor)
if major==pgfMajorVersion && minor<=pgfMinorVersion
then getPGF'
else if v==Old.version
then Old.getPGF'
else fail $ "Unsupported PGF version "++show (major,minor)
getPGF'=do gflags <- get
(absname,abstract) <- get
concretes <- get
return $ updateProductionIndices $
(PGF{ gflags=gflags
, absname=absname, abstract=abstract
, concretes=concretes
})
instance Binary CId where
put (CId bs) = put bs
get = liftM CId get
instance Binary Abstr where
put abs = do put (aflags abs)
put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs))
put (cats abs)
get = do aflags <- get
funs <- get
cats <- get
return (Abstr{ aflags=aflags
, funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
, cats=cats
})
putSplitAbs :: PGF -> Put
putSplitAbs pgf = do
putWord16be pgfMajorVersion
putWord16be pgfMinorVersion
put (Map.insert (mkCId "split") (LStr "true") (gflags pgf))
put (absname pgf, abstract pgf)
put [(name,cflags cnc) | (name,cnc) <- Map.toList (concretes pgf)]
instance Binary Concr where
put cnc = do put (cflags cnc)
put (printnames cnc)
putArray2 (sequences cnc)
putArray (cncfuns cnc)
put (lindefs cnc)
put (linrefs cnc)
put (productions cnc)
put (cnccats cnc)
put (totalCats cnc)
get = do cflags <- get
printnames <- get
sequences <- getArray2
cncfuns <- getArray
lindefs <- get
linrefs <- get
productions <- get
cnccats <- get
totalCats <- get
return (Concr{ cflags=cflags, printnames=printnames
, sequences=sequences, cncfuns=cncfuns
, lindefs=lindefs, linrefs=linrefs
, productions=productions
, pproductions = IntMap.empty
, lproductions = Map.empty
, lexicon = IntMap.empty
, cnccats=cnccats, totalCats=totalCats
})
instance Binary Expr where
put (EAbs b x exp) = putWord8 0 >> put (b,x,exp)
put (EApp e1 e2) = putWord8 1 >> put (e1,e2)
put (ELit l) = putWord8 2 >> put l
put (EMeta i) = putWord8 3 >> put i
put (EFun f) = putWord8 4 >> put f
put (EVar i) = putWord8 5 >> put i
put (ETyped e ty) = putWord8 6 >> put (e,ty)
put (EImplArg e) = putWord8 7 >> put e
get = do tag <- getWord8
case tag of
0 -> liftM3 EAbs get get get
1 -> liftM2 EApp get get
2 -> liftM ELit get
3 -> liftM EMeta get
4 -> liftM EFun get
5 -> liftM EVar get
6 -> liftM2 ETyped get get
7 -> liftM EImplArg get
_ -> decodingError
instance Binary Patt where
put (PApp f ps) = putWord8 0 >> put (f,ps)
put (PVar x) = putWord8 1 >> put x
put (PAs x p) = putWord8 2 >> put (x,p)
put PWild = putWord8 3
put (PLit l) = putWord8 4 >> put l
put (PImplArg p) = putWord8 5 >> put p
put (PTilde p) = putWord8 6 >> put p
get = do tag <- getWord8
case tag of
0 -> liftM2 PApp get get
1 -> liftM PVar get
2 -> liftM2 PAs get get
3 -> return PWild
4 -> liftM PLit get
5 -> liftM PImplArg get
6 -> liftM PTilde get
_ -> decodingError
instance Binary Equation where
put (Equ ps e) = put (ps,e)
get = liftM2 Equ get get
instance Binary Instr where
put (CHECK_ARGS n) = putWord8 0 >> put n
put (CASE id l) = putWord8 4 >> put (id,l)
put (CASE_LIT (LInt n) l) = putWord8 8 >> put (n,l)
put (CASE_LIT (LStr s) l) = putWord8 9 >> put (s,l)
put (CASE_LIT (LFlt d) l) = putWord8 10 >> put (d,l)
put (SAVE n) = putWord8 12 >> put n
put (ALLOC n) = putWord8 16 >> put n
put (PUT_CONSTR id) = putWord8 20 >> put id
put (PUT_CLOSURE l) = putWord8 24 >> put l
put (PUT_LIT (LInt n)) = putWord8 28 >> put n
put (PUT_LIT (LStr s)) = putWord8 29 >> put s
put (PUT_LIT (LFlt d)) = putWord8 30 >> put d
put (SET (HEAP n)) = putWord8 32 >> put n
put (SET (ARG_VAR n)) = putWord8 33 >> put n
put (SET (FREE_VAR n)) = putWord8 34 >> put n
put (SET (GLOBAL id)) = putWord8 35 >> put id
put (SET_PAD ) = putWord8 36
put (PUSH_FRAME ) = putWord8 40
put (PUSH (HEAP n)) = putWord8 44 >> put n
put (PUSH (ARG_VAR n)) = putWord8 45 >> put n
put (PUSH (FREE_VAR n)) = putWord8 46 >> put n
put (PUSH (GLOBAL id)) = putWord8 47 >> put id
put (TUCK (HEAP n) i) = putWord8 48 >> put (n,i)
put (TUCK (ARG_VAR n) i) = putWord8 49 >> put (n,i)
put (TUCK (FREE_VAR n) i) = putWord8 50 >> put (n,i)
put (TUCK (GLOBAL id) i) = putWord8 51 >> put (id,i)
put (EVAL (HEAP n) RecCall) = putWord8 52 >> put n
put (EVAL (ARG_VAR n) RecCall) = putWord8 53 >> put n
put (EVAL (FREE_VAR n) RecCall) = putWord8 54 >> put n
put (EVAL (GLOBAL id) RecCall) = putWord8 55 >> put id
put (EVAL (HEAP n) (TailCall a)) = putWord8 56 >> put n >> put a
put (EVAL (ARG_VAR n) (TailCall a)) = putWord8 57 >> put n >> put a
put (EVAL (FREE_VAR n) (TailCall a)) = putWord8 58 >> put n >> put a
put (EVAL (GLOBAL id) (TailCall a)) = putWord8 59 >> put id >> put a
put (EVAL (HEAP n) UpdateCall) = putWord8 60 >> put n
put (EVAL (ARG_VAR n) UpdateCall) = putWord8 61 >> put n
put (EVAL (FREE_VAR n) UpdateCall) = putWord8 62 >> put n
put (EVAL (GLOBAL id) UpdateCall) = putWord8 63 >> put id
put (DROP n ) = putWord8 64 >> put n
put (JUMP l ) = putWord8 68 >> put l
put (FAIL ) = putWord8 72
put (PUSH_ACCUM (LInt n)) = putWord8 76 >> put n
put (PUSH_ACCUM (LStr s)) = putWord8 77 >> put s
put (PUSH_ACCUM (LFlt d)) = putWord8 78 >> put d
put (POP_ACCUM ) = putWord8 80
put (ADD ) = putWord8 84
instance Binary Type where
put (DTyp hypos cat exps) = put (hypos,cat,exps)
get = liftM3 DTyp get get get
instance Binary BindType where
put Explicit = putWord8 0
put Implicit = putWord8 1
get = do tag <- getWord8
case tag of
0 -> return Explicit
1 -> return Implicit
_ -> decodingError
instance Binary CncFun where
put (CncFun fun lins) = put fun >> putArray lins
get = liftM2 CncFun get getArray
instance Binary CncCat where
put (CncCat s e labels) = do put (s,e)
putArray labels
get = liftM3 CncCat get get getArray
instance Binary Symbol where
put (SymCat n l) = putWord8 0 >> put (n,l)
put (SymLit n l) = putWord8 1 >> put (n,l)
put (SymVar n l) = putWord8 2 >> put (n,l)
put (SymKS ts) = putWord8 3 >> put ts
put (SymKP d vs) = putWord8 4 >> put (d,vs)
put SymBIND = putWord8 5
put SymSOFT_BIND = putWord8 6
put SymNE = putWord8 7
put SymSOFT_SPACE = putWord8 8
put SymCAPIT = putWord8 9
put SymALL_CAPIT = putWord8 10
get = do tag <- getWord8
case tag of
0 -> liftM2 SymCat get get
1 -> liftM2 SymLit get get
2 -> liftM2 SymVar get get
3 -> liftM SymKS get
4 -> liftM2 (\d vs -> SymKP d vs) get get
5 -> return SymBIND
6 -> return SymSOFT_BIND
7 -> return SymNE
8 -> return SymSOFT_SPACE
9 -> return SymCAPIT
10-> return SymALL_CAPIT
_ -> decodingError
instance Binary PArg where
put (PArg hypos fid) = put (map snd hypos,fid)
get = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid)
instance Binary Production where
put (PApply ruleid args) = putWord8 0 >> put (ruleid,args)
put (PCoerce fcat) = putWord8 1 >> put fcat
get = do tag <- getWord8
case tag of
0 -> liftM2 PApply get get
1 -> liftM PCoerce get
_ -> decodingError
instance Binary Literal where
put (LStr s) = putWord8 0 >> put s
put (LInt i) = putWord8 1 >> put i
put (LFlt d) = putWord8 2 >> put d
get = do tag <- getWord8
case tag of
0 -> liftM LStr get
1 -> liftM LInt get
2 -> liftM LFlt get
_ -> decodingError
putArray :: (Binary e, IArray a e) => a Int e -> Put
putArray a = do put (rangeSize $ bounds a) -- write the length
mapM_ put (elems a) -- now the elems.
getArray :: (Binary e, IArray a e) => Get (a Int e)
getArray = do n <- get -- read the length
xs <- replicateM n get -- now the elems.
return (listArray (0,n-1) xs)
putArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => a1 Int (a2 Int e) -> Put
putArray2 a = do put (rangeSize $ bounds a) -- write the length
mapM_ putArray (elems a) -- now the elems.
getArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => Get (a1 Int (a2 Int e))
getArray2 = do n <- get -- read the length
xs <- replicateM n getArray -- now the elems.
return (listArray (0,n-1) xs)
decodingError = fail "This file was compiled with different version of GF"

89
src/runtime/haskell/PGF/ByteCode.hs
View File

@@ -1,89 +0,0 @@
module PGF.ByteCode(Literal(..),
CodeLabel, Instr(..), IVal(..), TailInfo(..),
ppLit, ppCode, ppInstr
) where
import PGF.CId
import Text.PrettyPrint
data Literal =
LStr String -- ^ string constant
| LInt Int -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
type CodeLabel = Int
data Instr
= CHECK_ARGS {-# UNPACK #-} !Int
| CASE CId {-# UNPACK #-} !CodeLabel
| CASE_LIT Literal {-# UNPACK #-} !CodeLabel
| SAVE {-# UNPACK #-} !Int
| ALLOC {-# UNPACK #-} !Int
| PUT_CONSTR CId
| PUT_CLOSURE {-# UNPACK #-} !CodeLabel
| PUT_LIT Literal
| SET IVal
| SET_PAD
| PUSH_FRAME
| PUSH IVal
| TUCK IVal {-# UNPACK #-} !Int
| EVAL IVal TailInfo
| DROP {-# UNPACK #-} !Int
| JUMP {-# UNPACK #-} !CodeLabel
| FAIL
| PUSH_ACCUM Literal
| POP_ACCUM
| ADD
data IVal
= HEAP {-# UNPACK #-} !Int
| ARG_VAR {-# UNPACK #-} !Int
| FREE_VAR {-# UNPACK #-} !Int
| GLOBAL CId
deriving Eq
data TailInfo
= RecCall
| TailCall {-# UNPACK #-} !Int
| UpdateCall
ppLit (LStr s) = text (show s)
ppLit (LInt n) = int n
ppLit (LFlt d) = double d
ppCode :: Int -> [[Instr]] -> Doc
ppCode l [] = empty
ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss
ppInstr (CHECK_ARGS n) = text "CHECK_ARGS " <+> int n
ppInstr (CASE id l ) = text "CASE " <+> ppCId id <+> ppLabel l
ppInstr (CASE_LIT lit l ) = text "CASE_LIT " <+> ppLit lit <+> ppLabel l
ppInstr (SAVE n) = text "SAVE " <+> int n
ppInstr (ALLOC n) = text "ALLOC " <+> int n
ppInstr (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
ppInstr (PUT_CLOSURE l) = text "PUT_CLOSURE" <+> ppLabel l
ppInstr (PUT_LIT lit ) = text "PUT_LIT " <+> ppLit lit
ppInstr (SET v) = text "SET " <+> ppIVal v
ppInstr (SET_PAD ) = text "SET_PAD"
ppInstr (PUSH_FRAME ) = text "PUSH_FRAME"
ppInstr (PUSH v) = text "PUSH " <+> ppIVal v
ppInstr (EVAL v ti) = text "EVAL " <+> ppIVal v <+> ppTailInfo ti
ppInstr (TUCK v n ) = text "TUCK " <+> ppIVal v <+> int n
ppInstr (DROP n ) = text "DROP " <+> int n
ppInstr (JUMP l ) = text "JUMP " <+> ppLabel l
ppInstr (FAIL ) = text "FAIL"
ppInstr (PUSH_ACCUM lit) = text "PUSH_ACCUM " <+> ppLit lit
ppInstr (POP_ACCUM ) = text "POP_ACCUM"
ppInstr (ADD ) = text "ADD"
ppIVal (HEAP n) = text "hp" <> parens (int n)
ppIVal (ARG_VAR n) = text "stk" <> parens (int n)
ppIVal (FREE_VAR n) = text "env" <> parens (int n)
ppIVal (GLOBAL id) = ppCId id
ppTailInfo RecCall = empty
ppTailInfo (TailCall n) = text "tail" <> parens (int n)
ppTailInfo UpdateCall = text "update"
ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)

95
src/runtime/haskell/PGF/CId.hs
View File

@@ -1,95 +0,0 @@
module PGF.CId (CId(..),
mkCId, wildCId,
readCId, showCId,
-- utils
utf8CId, pCId, pIdent, ppCId) where
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char
import qualified Text.ParserCombinators.ReadP as RP
import qualified Text.PrettyPrint as PP
-- | An abstract data type that represents
-- identifiers for functions and categories in PGF.
newtype CId = CId BS.ByteString deriving (Eq,Ord)
wildCId :: CId
wildCId = CId (BS.singleton '_')
-- | Creates a new identifier from 'String'
mkCId :: String -> CId
mkCId s = CId (UTF8.fromString s)
-- | Creates an identifier from a UTF-8-encoded 'ByteString'
utf8CId = CId
-- | Reads an identifier from 'String'. The function returns 'Nothing' if the string is not valid identifier.
readCId :: String -> Maybe CId
readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | Renders the identifier as 'String'
showCId :: CId -> String
showCId (CId x) =
let raw = UTF8.toString x
in if isIdent raw
then raw
else "'" ++ concatMap escape raw ++ "'"
where
isIdent [] = False
isIdent (c:cs) = isIdentFirst c && all isIdentRest cs
escape '\'' = "\\\'"
escape '\\' = "\\\\"
escape c = [c]
instance Show CId where
showsPrec _ = showString . showCId
instance Read CId where
readsPrec _ = RP.readP_to_S pCId
pCId :: RP.ReadP CId
pCId = do s <- pIdent
if s == "_"
then RP.pfail
else return (mkCId s)
pIdent :: RP.ReadP String
pIdent =
liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
`mplus`
do RP.char '\''
cs <- RP.many1 insideChar
RP.char '\''
return cs
-- where
insideChar = RP.readS_to_P $ \s ->
case s of
[] -> []
('\\':'\\':cs) -> [('\\',cs)]
('\\':'\'':cs) -> [('\'',cs)]
('\\':cs) -> []
('\'':cs) -> []
(c:cs) -> [(c,cs)]
isIdentFirst c =
(c == '_') ||
(c >= 'a' && c <= 'z') ||
(c >= 'A' && c <= 'Z') ||
(c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
isIdentRest c =
(c == '_') ||
(c == '\'') ||
(c >= '0' && c <= '9') ||
(c >= 'a' && c <= 'z') ||
(c >= 'A' && c <= 'Z') ||
(c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
ppCId :: CId -> PP.Doc
ppCId = PP.text . showCId

127
src/runtime/haskell/PGF/Data.hs
View File

@@ -1,127 +0,0 @@
module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where
import PGF.CId
import PGF.Expr hiding (Value, Sig, Env, Tree, eval, apply, applyValue, value2expr)
import PGF.ByteCode
import PGF.Type
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified PGF.TrieMap as TMap
import Data.Array.IArray
import Data.Array.Unboxed
--import Data.List
-- internal datatypes for PGF
-- | An abstract data type representing multilingual grammar
-- in Portable Grammar Format.
data PGF = PGF {
gflags :: Map.Map CId Literal, -- value of a global flag
absname :: CId ,
abstract :: Abstr ,
concretes :: Map.Map CId Concr
}
data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double),-- ^ type, arrity and definition of function + probability
cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category
-- 2. functions of a category. The functions are stored
-- in decreasing probability order.
-- 3. probability
}
data Concr = Concr {
cflags :: Map.Map CId Literal, -- value of a flag
printnames :: Map.Map CId String, -- printname of a cat or a fun
cncfuns :: Array FunId CncFun,
lindefs :: IntMap.IntMap [FunId],
linrefs :: IntMap.IntMap [FunId],
sequences :: Array SeqId Sequence,
productions :: IntMap.IntMap (Set.Set Production), -- the original productions loaded from the PGF file
pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing
lproductions :: Map.Map CId (IntMap.IntMap (Set.Set Production)), -- productions needed for linearization
cnccats :: Map.Map CId CncCat,
lexicon :: IntMap.IntMap (IntMap.IntMap (TMap.TrieMap Token IntSet.IntSet)),
totalCats :: {-# UNPACK #-} !FId
}
type Token = String
type FId = Int
type LIndex = Int
type DotPos = Int
data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
| SymKS Token
| SymKP [Symbol] [([Symbol],[String])]
| SymBIND -- the special BIND token
| SymNE -- non exist
| SymSOFT_BIND -- the special SOFT_BIND token
| SymSOFT_SPACE -- the special SOFT_SPACE token
| SymCAPIT -- the special CAPIT token
| SymALL_CAPIT -- the special ALL_CAPIT token
deriving (Eq,Ord,Show)
data Production
= PApply {-# UNPACK #-} !FunId [PArg]
| PCoerce {-# UNPACK #-} !FId
| PConst CId Expr [Token]
deriving (Eq,Ord,Show)
data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
data CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String)
data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show)
type Sequence = Array DotPos Symbol
type FunId = Int
type SeqId = Int
-- merge two PGFs; fails if different abstract names; priority to second arg
unionPGF :: PGF -> PGF -> PGF
unionPGF one two = fst $ msgUnionPGF one two
msgUnionPGF :: PGF -> PGF -> (PGF, Maybe String)
msgUnionPGF one two = case absname one of
n | n == wildCId -> (two, Nothing) -- extending empty grammar
| n == absname two && haveSameFunsPGF one two -> (one { -- extending grammar with same abstract
concretes = Map.union (concretes two) (concretes one)
}, Nothing)
_ -> (two, -- abstracts don't match, discard the old one -- error msg in Importing.ioUnionPGF
Just "Abstract changed, previous concretes discarded.")
-- sameness of function type signatures, checked when importing a new concrete in env
haveSameFunsPGF :: PGF -> PGF -> Bool
haveSameFunsPGF one two =
let
fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))]
fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))]
in fsone == fstwo
-- | This is just a 'CId' with the language name.
-- A language name is the identifier that you write in the
-- top concrete or abstract module in GF after the
-- concrete/abstract keyword. Example:
--
-- > abstract Lang = ...
-- > concrete LangEng of Lang = ...
type Language = CId
readLanguage :: String -> Maybe Language
readLanguage = readCId
showLanguage :: Language -> String
showLanguage = showCId
fidString, fidInt, fidFloat, fidVar, fidStart :: FId
fidString = (-1)
fidInt = (-2)
fidFloat = (-3)
fidVar = (-4)
fidStart = (-5)
isPredefFId :: FId -> Bool
isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar])

241
src/runtime/haskell/PGF/Editor.hs
View File

@@ -1,241 +0,0 @@
module PGF.Editor (
State, -- datatype -- type-annotated possibly open tree with a focus
Dict, -- datatype -- abstract syntax information optimized for editing
Position, -- datatype -- path from top to focus
new, -- :: Type -> State -- create new State
refine, -- :: Dict -> CId -> State -> State -- refine focus with CId
replace, -- :: Dict -> Tree -> State -> State -- replace focus with Tree
delete, -- :: State -> State -- replace focus with ?
goNextMeta, -- :: State -> State -- move focus to next ? node
goNext, -- :: State -> State -- move to next node
goTop, -- :: State -> State -- move focus to the top (=root)
goPosition, -- :: Position -> State -> State -- move focus to given position
mkPosition, -- :: [Int] -> Position -- list of choices (top = [])
showPosition,-- :: Position -> [Int] -- readable position
focusType, -- :: State -> Type -- get the type of focus
stateTree, -- :: State -> Tree -- get the current tree
isMetaFocus, -- :: State -> Bool -- whether focus is ?
allMetas, -- :: State -> [(Position,Type)] -- all ?s and their positions
prState, -- :: State -> String -- print state, focus marked *
refineMenu, -- :: Dict -> State -> [CId] -- get refinement menu
pgf2dict -- :: PGF -> Dict -- create editing Dict from PGF
) where
import PGF.Data
import PGF.CId
import qualified Data.Map as M
import Debug.Trace ----
-- API
new :: Type -> State
new (DTyp _ t _) = etree2state (uETree t)
refine :: Dict -> CId -> State -> State
refine dict f = replaceInState (mkRefinement dict f)
replace :: Dict -> Tree -> State -> State
replace dict t = replaceInState (tree2etree dict t)
delete :: State -> State
delete s = replaceInState (uETree (typ (tree s))) s
goNextMeta :: State -> State
goNextMeta s =
if isComplete s then s
else let s1 = goNext s in if isMetaFocus s1
then s1 else goNextMeta s1
isComplete :: State -> Bool
isComplete s = isc (tree s) where
isc t = case atom t of
AMeta _ -> False
ACon _ -> all isc (children t)
goTop :: State -> State
goTop = navigate (const top)
goPosition :: [Int] -> State -> State
goPosition p s = s{position = p}
mkPosition :: [Int] -> Position
mkPosition = id
refineMenu :: Dict -> State -> [CId]
refineMenu dict s = maybe [] (map fst) $ M.lookup (focusBType s) (refines dict)
focusType :: State -> Type
focusType s = btype2type (focusBType s)
stateTree :: State -> Tree
stateTree = etree2tree . tree
pgf2dict :: PGF -> Dict
pgf2dict pgf = Dict (M.fromAscList fus) refs where
fus = [(f,mkFType ty) | (f,(ty,_)) <- M.toList (funs abs)]
refs = M.fromAscList [(c, fusTo c) | (c,_) <- M.toList (cats abs)]
fusTo c = [(f,ty) | (f,ty@(_,k)) <- fus, k==c] ---- quadratic
mkFType (DTyp hyps c _) = ([k | Hyp _ (DTyp _ k _) <- hyps],c) ----dep types
abs = abstract pgf
etree2tree :: ETree -> Tree
etree2tree t = case atom t of
ACon f -> Fun f (map etree2tree (children t))
AMeta i -> Meta i
tree2etree :: Dict -> Tree -> ETree
tree2etree dict t = case t of
Fun f _ -> annot (look f) t
where
annot (tys,ty) tr = case tr of
Fun f trs -> ETree (ACon f) ty [annt t tr | (t,tr) <- zip tys trs]
Meta i -> ETree (AMeta i) ty []
annt ty tr = case tr of
Fun _ _ -> tree2etree dict tr
Meta _ -> annot ([],ty) tr
look f = maybe undefined id $ M.lookup f (functs dict)
prState :: State -> String
prState s = unlines [replicate i ' ' ++ f | (i,f) <- pr [] (tree s)] where
pr i t =
(ind i,prAtom i (atom t)) : concat [pr (sub j i) c | (j,c) <- zip [0..] (children t)]
prAtom i a = prFocus i ++ case a of
ACon f -> prCId f
AMeta i -> "?" ++ show i
prFocus i = if i == position s then "*" else ""
ind i = 2 * length i
sub j i = i ++ [j]
showPosition :: Position -> [Int]
showPosition = id
allMetas :: State -> [(Position,Type)]
allMetas s = [(reverse p, btype2type ty) | (p,ty) <- metas [] (tree s)] where
metas p t =
(if isMetaAtom (atom t) then [(p,typ t)] else []) ++
concat [metas (i:p) u | (i,u) <- zip [0..] (children t)]
---- Trees and navigation
data ETree = ETree {
atom :: Atom,
typ :: BType,
children :: [ETree]
}
deriving Show
data Atom =
ACon CId
| AMeta Int
deriving Show
btype2type :: BType -> Type
btype2type t = DTyp [] t []
uETree :: BType -> ETree
uETree ty = ETree (AMeta 0) ty []
data State = State {
position :: Position,
tree :: ETree
}
deriving Show
type Position = [Int]
top :: Position
top = []
up :: Position -> Position
up p = case p of
_:_ -> init p
_ -> p
down :: Position -> Position
down = (++[0])
left :: Position -> Position
left p = case p of
_:_ | last p > 0 -> init p ++ [last p - 1]
_ -> top
right :: Position -> Position
right p = case p of
_:_ -> init p ++ [last p + 1]
_ -> top
etree2state :: ETree -> State
etree2state = State top
doInState :: (ETree -> ETree) -> State -> State
doInState f s = s{tree = change (position s) (tree s)} where
change p t = case p of
[] -> f t
n:ns -> let (ts1,t0:ts2) = splitAt n (children t) in
t{children = ts1 ++ [change ns t0] ++ ts2}
subtree :: Position -> ETree -> ETree
subtree p t = case p of
[] -> t
n:ns -> subtree ns (children t !! n)
focus :: State -> ETree
focus s = subtree (position s) (tree s)
focusBType :: State -> BType
focusBType s = typ (focus s)
navigate :: (Position -> Position) -> State -> State
navigate p s = s{position = p (position s)}
-- p is a fix-point aspect of state change
untilFix :: Eq a => (State -> a) -> (State -> Bool) -> (State -> State) -> State -> State
untilFix p b f s =
if b s
then s
else let fs = f s in if p fs == p s
then s
else untilFix p b f fs
untilPosition :: (State -> Bool) -> (State -> State) -> State -> State
untilPosition = untilFix position
goNext :: State -> State
goNext s = case focus s of
st | not (null (children st)) -> navigate down s
_ -> findSister s
where
findSister s = case s of
s' | null (position s') -> s'
s' | hasYoungerSisters s' -> navigate right s'
s' -> findSister (navigate up s')
hasYoungerSisters s = case position s of
p@(_:_) -> length (children (focus (navigate up s))) > last p + 1
_ -> False
isMetaFocus :: State -> Bool
isMetaFocus s = isMetaAtom (atom (focus s))
isMetaAtom :: Atom -> Bool
isMetaAtom a = case a of
AMeta _ -> True
_ -> False
replaceInState :: ETree -> State -> State
replaceInState t = doInState (const t)
-------
type BType = CId ----dep types
type FType = ([BType],BType) ----dep types
data Dict = Dict {
functs :: M.Map CId FType,
refines :: M.Map BType [(CId,FType)]
}
mkRefinement :: Dict -> CId -> ETree
mkRefinement dict f = ETree (ACon f) val (map uETree args) where
(args,val) = maybe undefined id $ M.lookup f (functs dict)

417
src/runtime/haskell/PGF/Expr.hs
View File

@@ -1,417 +0,0 @@
module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..),
readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, pattScope,
mkAbs, unAbs,
mkApp, unApp, unapply,
mkStr, unStr,
mkInt, unInt,
mkDouble, unDouble,
mkFloat, unFloat,
mkMeta, unMeta,
exprSubstitute,
normalForm,
-- needed in the typechecker
Value(..), Env, Sig, eval, apply, applyValue, value2expr,
MetaId,
-- helpers
pMeta,pArg,pLit,freshName,ppMeta,ppLit,ppParens
) where
import PGF.CId
import PGF.Type
import PGF.ByteCode
import Data.Char
--import Data.Maybe
import Data.List as List
import qualified Data.Map as Map hiding (showTree)
import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
type MetaId = Int
data BindType =
Explicit
| Implicit
deriving (Eq,Ord,Show)
-- | Tree is the abstract syntax representation of a given sentence
-- in some concrete syntax. Technically 'Tree' is a type synonym
-- of 'Expr'.
type Tree = Expr
-- | An expression in the abstract syntax of the grammar. It could be
-- both parameter of a dependent type or an abstract syntax tree for
-- for some sentence.
data Expr =
EAbs BindType CId Expr -- ^ lambda abstraction
| EApp Expr Expr -- ^ application
| ELit Literal -- ^ literal
| EMeta {-# UNPACK #-} !MetaId -- ^ meta variable
| EFun CId -- ^ function or data constructor
| EVar {-# UNPACK #-} !Int -- ^ variable with de Bruijn index
| ETyped Expr Type -- ^ local type signature
| EImplArg Expr -- ^ implicit argument in expression
deriving (Eq,Ord,Show)
-- | The pattern is used to define equations in the abstract syntax of the grammar.
data Patt =
PApp CId [Patt] -- ^ application. The identifier should be constructor i.e. defined with 'data'
| PLit Literal -- ^ literal
| PVar CId -- ^ variable
| PAs CId Patt -- ^ variable@pattern
| PWild -- ^ wildcard
| PImplArg Patt -- ^ implicit argument in pattern
| PTilde Expr
deriving Show
-- | The equation is used to define lambda function as a sequence
-- of equations with pattern matching. The list of 'Expr' represents
-- the patterns and the second 'Expr' is the function body for this
-- equation.
data Equation =
Equ [Patt] Expr
deriving Show
-- | parses 'String' as an expression
readExpr :: String -> Maybe Expr
readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'. The list
-- of identifiers is the list of all free variables
-- in the expression in order reverse to the order
-- of binding.
showExpr :: [CId] -> Expr -> String
showExpr vars = PP.render . ppExpr 0 vars
instance Read Expr where
readsPrec _ = RP.readP_to_S pExpr
mkAbs :: BindType -> CId -> Expr -> Expr
mkAbs = EAbs
unAbs :: Expr -> Maybe (BindType, CId, Expr)
unAbs (EAbs bt x e) = Just (bt,x,e)
unAbs (ETyped e ty) = unAbs e
unAbs (EImplArg e) = unAbs e
unAbs _ = Nothing
-- | Constructs an expression by applying a function to a list of expressions
mkApp :: CId -> [Expr] -> Expr
mkApp f es = foldl EApp (EFun f) es
-- | Decomposes an expression into application of function
unApp :: Expr -> Maybe (CId,[Expr])
unApp e = case unapply e of
(EFun f,es) -> Just (f,es)
_ -> Nothing
-- | Decomposes an expression into an application of a constructor such as a constant or a metavariable
unapply :: Expr -> (Expr,[Expr])
unapply = extract []
where
extract es f@(EFun _) = (f,es)
extract es (EApp e1 e2) = extract (e2:es) e1
extract es (ETyped e ty)= extract es e
extract es (EImplArg e) = extract es e
extract es h = (h,es)
-- | Constructs an expression from string literal
mkStr :: String -> Expr
mkStr s = ELit (LStr s)
-- | Decomposes an expression into string literal
unStr :: Expr -> Maybe String
unStr (ELit (LStr s)) = Just s
unStr (ETyped e ty) = unStr e
unStr (EImplArg e) = unStr e
unStr _ = Nothing
-- | Constructs an expression from integer literal
mkInt :: Int -> Expr
mkInt i = ELit (LInt i)
-- | Decomposes an expression into integer literal
unInt :: Expr -> Maybe Int
unInt (ELit (LInt i)) = Just i
unInt (ETyped e ty) = unInt e
unInt (EImplArg e) = unInt e
unInt _ = Nothing
-- | Constructs an expression from real number literal
mkDouble :: Double -> Expr
mkDouble f = ELit (LFlt f)
-- | Decomposes an expression into real number literal
unDouble :: Expr -> Maybe Double
unDouble (ELit (LFlt f)) = Just f
unDouble (ETyped e ty) = unDouble e
unDouble (EImplArg e) = unDouble e
unDouble _ = Nothing
mkFloat = mkDouble
unFloat = unDouble
-- | Constructs an expression which is meta variable
mkMeta :: Int -> Expr
mkMeta i = EMeta i
-- | Checks whether an expression is a meta variable
unMeta :: Expr -> Maybe Int
unMeta (EMeta i) = Just i
unMeta (ETyped e ty) = unMeta e
unMeta (EImplArg e) = unMeta e
unMeta _ = Nothing
exprSubstitute :: Expr -> [Expr] -> Expr
exprSubstitute e es =
case e of
EAbs b x e -> EAbs b x (exprSubstitute e es)
EApp e1 e2 -> EApp (exprSubstitute e1 es) (exprSubstitute e2 es)
ELit l -> ELit l
EMeta i -> es !! i
EFun x -> EFun x
-----------------------------------------------------
-- Parsing
-----------------------------------------------------
pExpr :: RP.ReadP Expr
pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm)
where
pTerm = do f <- pFactor
RP.skipSpaces
as <- RP.sepBy pArg RP.skipSpaces
return (foldl EApp f as)
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") pBinds
e <- pExpr
return (foldr (\(b,x) e -> EAbs b x e) e xs)
pBinds :: RP.ReadP [(BindType,CId)]
pBinds = do xss <- RP.sepBy1 (RP.skipSpaces >> pBind) (RP.skipSpaces >> RP.char ',')
return (concat xss)
where
pCIdOrWild = pCId `mplus` (RP.char '_' >> return wildCId)
pBind =
do x <- pCIdOrWild
return [(Explicit,x)]
`mplus`
RP.between (RP.char '{')
(RP.skipSpaces >> RP.char '}')
(RP.sepBy1 (RP.skipSpaces >> pCIdOrWild >>= \id -> return (Implicit,id)) (RP.skipSpaces >> RP.char ','))
pArg = fmap EImplArg (RP.between (RP.char '{') (RP.char '}') pExpr)
RP.<++
pFactor
pFactor = fmap EFun pCId
RP.<++ fmap ELit pLit
RP.<++ fmap EMeta pMeta
RP.<++ RP.between (RP.char '(') (RP.skipSpaces >> RP.char ')') pExpr
RP.<++ RP.between (RP.char '<') (RP.skipSpaces >> RP.char '>') pTyped
pTyped = do RP.skipSpaces
e <- pExpr
RP.skipSpaces
RP.char ':'
RP.skipSpaces
ty <- pType
return (ETyped e ty)
pMeta = do RP.char '?'
ds <- RP.munch isDigit
return (read ('0':ds))
pLit :: RP.ReadP Literal
pLit = liftM LStr (RP.readS_to_P reads)
RP.<++
liftM LInt (RP.readS_to_P reads)
RP.<++
liftM LFlt (RP.readS_to_P reads)
-----------------------------------------------------
-- Printing
-----------------------------------------------------
ppExpr :: Int -> [CId] -> Expr -> PP.Doc
ppExpr d scope (EAbs b x e) = let (bs,xs,e1) = getVars [] [] (EAbs b x e)
in ppParens (d > 1) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (reverse (List.zipWith ppBind bs xs))) PP.<+>
PP.text "->" PP.<+>
ppExpr 1 (xs++scope) e1)
where
getVars bs xs (EAbs b x e) = getVars (b:bs) ((freshName x xs):xs) e
getVars bs xs e = (bs,xs,e)
ppExpr d scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 scope e1) PP.<+> (ppExpr 4 scope e2))
ppExpr d scope (ELit l) = ppLit l
ppExpr d scope (EMeta n) = ppMeta n
ppExpr d scope (EFun f) = ppCId f
ppExpr d scope (EVar i) = ppCId (scope !! i)
ppExpr d scope (ETyped e ty)= PP.char '<' PP.<> ppExpr 0 scope e PP.<+> PP.colon PP.<+> ppType 0 scope ty PP.<> PP.char '>'
ppExpr d scope (EImplArg e) = PP.braces (ppExpr 0 scope e)
ppPatt :: Int -> [CId] -> Patt -> PP.Doc
ppPatt d scope (PApp f ps) = let ds = List.map (ppPatt 2 scope) ps
in ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds)
ppPatt d scope (PLit l) = ppLit l
ppPatt d scope (PVar f) = ppCId f
ppPatt d scope (PAs x p) = ppCId x PP.<> PP.char '@' PP.<> ppPatt 3 scope p
ppPatt d scope PWild = PP.char '_'
ppPatt d scope (PImplArg p) = PP.braces (ppPatt 0 scope p)
ppPatt d scope (PTilde e) = PP.char '~' PP.<> ppExpr 6 scope e
pattScope :: [CId] -> Patt -> [CId]
pattScope scope (PApp f ps) = foldl pattScope scope ps
pattScope scope (PLit l) = scope
pattScope scope (PVar f) = f:scope
pattScope scope (PAs x p) = pattScope (x:scope) p
pattScope scope PWild = scope
pattScope scope (PImplArg p) = pattScope scope p
pattScope scope (PTilde e) = scope
ppBind Explicit x = ppCId x
ppBind Implicit x = PP.braces (ppCId x)
ppMeta :: MetaId -> PP.Doc
ppMeta n
| n == 0 = PP.char '?'
| otherwise = PP.char '?' PP.<> PP.int n
ppParens True = PP.parens
ppParens False = id
freshName :: CId -> [CId] -> CId
freshName x xs0 = loop 1 x
where
xs = wildCId : xs0
loop i y
| elem y xs = loop (i+1) (mkCId (show x++show i))
| otherwise = y
-----------------------------------------------------
-- Computation
-----------------------------------------------------
-- | Compute an expression to normal form
normalForm :: Sig -> Int -> Env -> Expr -> Expr
normalForm sig k env e = value2expr sig k (eval sig env e)
value2expr sig i (VApp f vs) = foldl EApp (EFun f) (List.map (value2expr sig i) vs)
value2expr sig i (VGen j vs) = foldl EApp (EVar (i-j-1)) (List.map (value2expr sig i) vs)
value2expr sig i (VMeta j env vs) = case snd sig j of
Just e -> value2expr sig i (apply sig env e vs)
Nothing -> foldl EApp (EMeta j) (List.map (value2expr sig i) vs)
value2expr sig i (VSusp j env vs k) = value2expr sig i (k (VGen j vs))
value2expr sig i (VConst f vs) = foldl EApp (EFun f) (List.map (value2expr sig i) vs)
value2expr sig i (VLit l) = ELit l
value2expr sig i (VClosure env (EAbs b x e)) = EAbs b (mkCId ('v':show i)) (value2expr sig (i+1) (eval sig ((VGen i []):env) e))
value2expr sig i (VImplArg v) = EImplArg (value2expr sig i v)
data Value
= VApp CId [Value]
| VLit Literal
| VMeta {-# UNPACK #-} !MetaId Env [Value]
| VSusp {-# UNPACK #-} !MetaId Env [Value] (Value -> Value)
| VGen {-# UNPACK #-} !Int [Value]
| VConst CId [Value]
| VClosure Env Expr
| VImplArg Value
type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun
, Int -> Maybe Expr -- lookup for metavariables
)
type Env = [Value]
eval :: Sig -> Env -> Expr -> Value
eval sig env (EVar i) = env !! i
eval sig env (EFun f) = case Map.lookup f (fst sig) of
Just (_,a,meqs,_) -> case meqs of
Just (eqs,_)
-> if a == 0
then case eqs of
Equ [] e : _ -> eval sig [] e
_ -> VConst f []
else VApp f []
Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f)
eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2]
eval sig env (EAbs b x e) = VClosure env (EAbs b x e)
eval sig env (EMeta i) = case snd sig i of
Just e -> eval sig env e
Nothing -> VMeta i env []
eval sig env (ELit l) = VLit l
eval sig env (ETyped e _) = eval sig env e
eval sig env (EImplArg e) = VImplArg (eval sig env e)
apply :: Sig -> Env -> Expr -> [Value] -> Value
apply sig env e [] = eval sig env e
apply sig env (EVar i) vs = applyValue sig (env !! i) vs
apply sig env (EFun f) vs = case Map.lookup f (fst sig) of
Just (_,a,meqs,_) -> case meqs of
Just (eqs,_) -> if a <= length vs
then match sig f eqs vs
else VApp f vs
Nothing -> VApp f vs
Nothing -> error ("unknown function "++showCId f)
apply sig env (EApp e1 e2) vs = apply sig env e1 (eval sig env e2 : vs)
apply sig env (EAbs b x e) (v:vs) = case (b,v) of
(Implicit,VImplArg v) -> apply sig (v:env) e vs
(Explicit, v) -> apply sig (v:env) e vs
apply sig env (EMeta i) vs = case snd sig i of
Just e -> apply sig env e vs
Nothing -> VMeta i env vs
apply sig env (ELit l) vs = error "literal of function type"
apply sig env (ETyped e _) vs = apply sig env e vs
apply sig env (EImplArg _) vs = error "implicit argument in function position"
applyValue sig v [] = v
applyValue sig (VApp f vs0) vs = apply sig [] (EFun f) (vs0++vs)
applyValue sig (VLit _) vs = error "literal of function type"
applyValue sig (VMeta i env vs0) vs = VMeta i env (vs0++vs)
applyValue sig (VGen i vs0) vs = VGen i (vs0++vs)
applyValue sig (VSusp i env vs0 k) vs = VSusp i env vs0 (\v -> applyValue sig (k v) vs)
applyValue sig (VConst f vs0) vs = VConst f (vs0++vs)
applyValue sig (VClosure env (EAbs b x e)) (v:vs) = case (b,v) of
(Implicit,VImplArg v) -> apply sig (v:env) e vs
(Explicit, v) -> apply sig (v:env) e vs
applyValue sig (VImplArg _) vs = error "implicit argument in function position"
-----------------------------------------------------
-- Pattern matching
-----------------------------------------------------
match :: Sig -> CId -> [Equation] -> [Value] -> Value
match sig f eqs as0 =
case eqs of
[] -> VConst f as0
(Equ ps res):eqs -> tryMatches eqs ps as0 res []
where
tryMatches eqs [] as res env = apply sig env res as
tryMatches eqs (p:ps) (a:as) res env = tryMatch p a env
where
tryMatch (PVar x ) (v ) env = tryMatches eqs ps as res (v:env)
tryMatch (PAs x p ) (v ) env = tryMatch p v (v:env)
tryMatch (PWild ) (_ ) env = tryMatches eqs ps as res env
tryMatch (p ) (VMeta i envi vs ) env = VSusp i envi vs (\v -> tryMatch p v env)
tryMatch (p ) (VGen i vs ) env = VConst f as0
tryMatch (p ) (VSusp i envi vs k) env = VSusp i envi vs (\v -> tryMatch p (k v) env)
tryMatch (p ) v@(VConst _ _ ) env = VConst f as0
tryMatch (PApp f1 ps1) (VApp f2 vs2 ) env | f1 == f2 = tryMatches eqs (ps1++ps) (vs2++as) res env
tryMatch (PLit l1 ) (VLit l2 ) env | l1 == l2 = tryMatches eqs ps as res env
tryMatch (PImplArg p ) (VImplArg v ) env = tryMatch p v env
tryMatch (PTilde _ ) (_ ) env = tryMatches eqs ps as res env
tryMatch _ _ env = match sig f eqs as0

28
src/runtime/haskell/PGF/Expr.hs-boot
View File

@@ -1,28 +0,0 @@
module PGF.Expr where
import PGF.CId
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
data Expr
instance Eq Expr
instance Ord Expr
instance Show Expr
data BindType = Explicit | Implicit
instance Eq BindType
instance Ord BindType
instance Show BindType
pArg :: RP.ReadP Expr
pBinds :: RP.ReadP [(BindType,CId)]
ppExpr :: Int -> [CId] -> Expr -> PP.Doc
freshName :: CId -> [CId] -> CId
ppParens :: Bool -> PP.Doc -> PP.Doc

210
src/runtime/haskell/PGF/Forest.hs
View File

@@ -1,210 +0,0 @@
{-# LANGUAGE TypeSynonymInstances #-}
-------------------------------------------------
-- |
-- Module : PGF
-- Maintainer : Krasimir Angelov
-- Stability : stable
-- Portability : portable
--
-- Forest is a compact representation of a set
-- of parse trees. This let us to efficiently
-- represent local ambiguities
--
-------------------------------------------------
module PGF.Forest( Forest(..)
, BracketedString, showBracketedString, lengthBracketedString
, linearizeWithBrackets
, getAbsTrees
) where
import PGF.CId
import PGF.Data
import PGF.Macros
import PGF.TypeCheck
import PGF.Generate
import Data.List
import Data.Array.IArray
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntSet as IntSet
import qualified Data.IntMap as IntMap
import Control.Monad
import Control.Monad.State
import PGF.Utilities (nub')
data Forest
= Forest
{ abstr :: Abstr
, concr :: Concr
, forest :: IntMap.IntMap (Set.Set Production)
, root :: [([Symbol],[PArg])]
}
--------------------------------------------------------------------
-- Rendering of bracketed strings
--------------------------------------------------------------------
linearizeWithBrackets :: Maybe Int -> Forest -> BracketedString
linearizeWithBrackets dp = head . snd . untokn Nothing . (:[]) .bracketedTokn dp
---------------------------------------------------------------
-- Internally we have to do everything with Tokn first because
-- we must handle the pre {...} construction.
--
bracketedTokn :: Maybe Int -> Forest -> BracketedTokn
bracketedTokn dp f@(Forest abs cnc forest root) =
case [computeSeq isTrusted seq (map (render forest) args) | (seq,args) <- root] of
([bs@(Bracket_{})]:_) -> bs
(bss:_) -> Bracket_ wildCId 0 0 0 wildCId [] bss
[] -> Bracket_ wildCId 0 0 0 wildCId [] []
where
isTrusted (_,fid) = IntSet.member fid trusted
trusted = foldl1 IntSet.intersection [IntSet.unions (map (trustedSpots IntSet.empty) args) | (_,args) <- root]
render forest arg@(PArg hypos fid) =
case IntMap.lookup fid forest >>= Set.maxView of
Just (p,set) -> let (ct,fid',fun,es,(_,lin)) = descend (if Set.null set then forest else IntMap.insert fid set forest) p
in (ct,fid',fun,es,(map getVar hypos,lin))
Nothing -> error ("wrong forest id " ++ show fid)
where
descend forest (PApply funid args) = let (CncFun fun _lins) = cncfuns cnc ! funid
cat = case isLindefCId fun of
Just cat -> cat
Nothing -> case Map.lookup fun (funs abs) of
Just (DTyp _ cat _,_,_,_) -> cat
largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
descend forest (PCoerce fid) = render forest (PArg [] fid)
descend forest (PConst cat e ts) = ((cat,fid),0,wildCId,[e],([],listArray (0,0) [map LeafKS ts]))
getVar (fid,_)
| fid == fidVar = wildCId
| otherwise = x
where
(x:_) = [x | PConst _ (EFun x) _ <- maybe [] Set.toList (IntMap.lookup fid forest)]
trustedSpots parents (PArg _ fid)
| fid < totalCats cnc || -- forest ids from the grammar correspond to metavariables
IntSet.member fid parents -- this avoids loops in the grammar
= IntSet.empty
| otherwise = IntSet.insert fid $
case IntMap.lookup fid forest of
Just prods -> foldl1 IntSet.intersection [descend prod | prod <- Set.toList prods]
Nothing -> IntSet.empty
where
parents' = IntSet.insert fid parents
descend (PApply funid args) = IntSet.unions (map (trustedSpots parents') args)
descend (PCoerce fid) = trustedSpots parents' (PArg [] fid)
descend (PConst c e _) = IntSet.empty
isLindefCId id
| take l s == lindef = Just (mkCId (drop l s))
| otherwise = Nothing
where
s = showCId id
lindef = "lindef "
l = length lindef
-- | This function extracts the list of all completed parse trees
-- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually
-- the same as the startup category.
getAbsTrees :: Forest -> PArg -> Maybe Type -> Maybe Int -> Either [(FId,TcError)] [Expr]
getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty dp =
let (err,res) = runTcM abs (do e <- go Set.empty emptyScope (fmap (TTyp []) ty) arg
generateForForest (prove dp) e) emptyMetaStore fid
in if null res
then Left (nub err)
else Right (nub' [e | (_,_,e) <- res])
where
go rec_ scope_ mb_tty_ (PArg hypos fid)
| fid < totalCats cnc = case mb_tty of
Just tty -> do i <- newMeta scope tty
return (mkAbs (EMeta i))
Nothing -> mzero
| Set.member fid rec_ = mzero
| otherwise = do fid0 <- get
put fid
x <- foldForest (\funid args trees ->
do let CncFun fn _lins = cncfuns cnc ! funid
case isLindefCId fn of
Just _ -> do arg <- go (Set.insert fid rec_) scope mb_tty (head args)
return (mkAbs arg)
Nothing -> do ty_fn <- lookupFunType fn
(e,tty0) <- foldM (\(e1,tty) arg -> goArg (Set.insert fid rec_) scope fid e1 arg tty)
(EFun fn,TTyp [] ty_fn) args
case mb_tty of
Just tty -> do i <- newGuardedMeta e
eqType scope (scopeSize scope) i tty tty0
Nothing -> return ()
return (mkAbs e)
`mplus`
trees)
(\const _ trees -> do
const <- case mb_tty of
Just tty -> tcExpr scope const tty
Nothing -> fmap fst $ infExpr scope const
return (mkAbs const)
`mplus`
trees)
mzero fid forest
put fid0
return x
where
(scope,mkAbs,mb_tty) = updateScope hypos scope_ id mb_tty_
goArg rec_ scope fid e1 arg (TTyp delta (DTyp ((bt,x,ty):hs) c es)) = do
e2' <- go rec_ scope (Just (TTyp delta ty)) arg
let e2 = case bt of
Explicit -> e2'
Implicit -> EImplArg e2'
if x == wildCId
then return (EApp e1 e2,TTyp delta (DTyp hs c es))
else do v2 <- eval (scopeEnv scope) e2'
return (EApp e1 e2,TTyp (v2:delta) (DTyp hs c es))
updateScope [] scope mkAbs mb_tty = (scope,mkAbs,mb_tty)
updateScope ((fid,_):hypos) scope mkAbs mb_tty =
case mb_tty of
Just (TTyp delta (DTyp ((bt,y,ty):hs) c es)) ->
if y == wildCId
then updateScope hypos (addScopedVar x (TTyp delta ty) scope)
(mkAbs . EAbs bt x)
(Just (TTyp delta (DTyp hs c es)))
else updateScope hypos (addScopedVar x (TTyp delta ty) scope)
(mkAbs . EAbs bt x)
(Just (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)))
Nothing -> (scope,mkAbs,Nothing)
where
(x:_) | fid == fidVar = [wildCId]
| otherwise = [x | PConst _ (EFun x) _ <- maybe [] Set.toList (IntMap.lookup fid forest)]
foldForest :: (FunId -> [PArg] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FId -> IntMap.IntMap (Set.Set Production) -> b
foldForest f g b fcat forest =
case IntMap.lookup fcat forest of
Nothing -> b
Just set -> Set.foldr foldProd b set
where
foldProd (PCoerce fcat) b = foldForest f g b fcat forest
foldProd (PApply funid args) b = f funid args b
foldProd (PConst _ const toks) b = g const toks b
------------------------------------------------------------------------------
-- Selectors
instance Selector FId where
splitSelector s = (s,s)
select cat scope dp = do
gens <- typeGenerators scope cat
TcM (\abstr k h -> iter k gens)
where
iter k [] ms s = id
iter k ((_,e,tty):fns) ms s = k (e,tty) ms s . iter k fns ms s

216
src/runtime/haskell/PGF/Generate.hs
View File

@@ -1,216 +0,0 @@
module PGF.Generate
( generateAll, generateAllDepth
, generateFrom, generateFromDepth
, generateRandom, generateRandomDepth
, generateRandomFrom, generateRandomFromDepth
, generateOntology, generateOntologyDepth
, prove
) where
import PGF.CId
import PGF.Data
import PGF.TypeCheck
import Control.Monad
import Control.Monad.State
import Control.Monad.Identity
import System.Random
import Data.Maybe(isNothing)
------------------------------------------------------------------------------
-- The API
-- | Generates an exhaustive possibly infinite list of
-- abstract syntax expressions.
generateAll :: PGF -> Type -> [Expr]
generateAll pgf ty = generateAllDepth pgf ty Nothing
-- | A variant of 'generateAll' which also takes as argument
-- the upper limit of the depth of the generated expression.
generateAllDepth :: PGF -> Type -> Maybe Int -> [Expr]
generateAllDepth pgf ty dp = generate () pgf ty dp
-- | Generates a list of abstract syntax expressions
-- in a way similar to 'generateAll' but instead of
-- generating all instances of a given type, this
-- function uses a template.
generateFrom :: PGF -> Expr -> [Expr]
generateFrom pgf ex = generateFromDepth pgf ex Nothing
-- | A variant of 'generateFrom' which also takes as argument
-- the upper limit of the depth of the generated subexpressions.
generateFromDepth :: PGF -> Expr -> Maybe Int -> [Expr]
generateFromDepth pgf e dp =
[e | (_,_,e) <- snd $ runTcM (abstract pgf)
(generateForMetas (prove dp) e)
emptyMetaStore ()]
-- | Generates an infinite list of random abstract syntax expressions.
-- This is usefull for tree bank generation which after that can be used
-- for grammar testing.
generateRandom :: RandomGen g => g -> PGF -> Type -> [Expr]
generateRandom g pgf ty = generateRandomDepth g pgf ty Nothing
-- | A variant of 'generateRandom' which also takes as argument
-- the upper limit of the depth of the generated expression.
generateRandomDepth :: RandomGen g => g -> PGF -> Type -> Maybe Int -> [Expr]
generateRandomDepth g pgf ty dp = restart g (\g -> generate (Identity g) pgf ty dp)
-- | Random generation based on template
generateRandomFrom :: RandomGen g => g -> PGF -> Expr -> [Expr]
generateRandomFrom g pgf e = generateRandomFromDepth g pgf e Nothing
-- | Random generation based on template with a limitation in the depth.
generateRandomFromDepth :: RandomGen g => g -> PGF -> Expr -> Maybe Int -> [Expr]
generateRandomFromDepth g pgf e dp =
restart g (\g -> [e | (_,ms,e) <- snd $ runTcM (abstract pgf)
(generateForMetas (prove dp) e)
emptyMetaStore (Identity g)])
generateOntology :: RandomGen g => g -> PGF -> Type -> [(Maybe Expr, Type)] -> [Expr]
generateOntology g pgf ty args = generateOntologyDepth g pgf ty args Nothing
generateOntologyDepth :: RandomGen g => g -> PGF -> Type -> [(Maybe Expr, Type)] -> Maybe Int -> [Expr]
generateOntologyDepth g pgf ty args dp =
restart g (\g -> [e | (_,(Ontology args' _),e) <- snd $ runTcM (abstract pgf)
(prove dp emptyScope (TTyp [] ty) >>= checkResolvedMetaStore emptyScope)
emptyMetaStore
(Ontology args g),
all (isNothing . fst) args'])
------------------------------------------------------------------------------
-- The main generation algorithm
generate :: Selector sel => sel -> PGF -> Type -> Maybe Int -> [Expr]
generate sel pgf ty dp =
[e | (_,ms,e) <- snd $ runTcM (abstract pgf)
(prove dp emptyScope (TTyp [] ty) >>= checkResolvedMetaStore emptyScope)
emptyMetaStore sel]
prove :: Selector sel => Maybe Int -> Scope -> TType -> TcM sel Expr
prove dp scope (TTyp env1 (DTyp hypos1 cat es1)) = do
vs1 <- mapM (PGF.TypeCheck.eval env1) es1
let scope' = exScope scope env1 hypos1
(fe,TTyp env2 (DTyp hypos2 _ es2)) <- select cat scope' dp
case dp of
Just 0 | not (null hypos2) -> mzero
_ -> return ()
(env2,args) <- mkEnv scope' env2 hypos2
vs2 <- mapM (PGF.TypeCheck.eval env2) es2
sequence_ [eqValue mzero suspend (scopeSize scope') v1 v2 | (v1,v2) <- zip vs1 vs2]
es <- mapM (descend scope') args
return (abs hypos1 (foldl EApp fe es))
where
suspend i c = do
mv <- getMeta i
case mv of
MBound e -> c e
MUnbound x scope tty cs -> setMeta i (MUnbound x scope tty (c:cs))
abs [] e = e
abs ((bt,x,ty):hypos) e = EAbs bt x (abs hypos e)
exScope scope env [] = scope
exScope scope env ((bt,x,ty):hypos) =
let env' | x /= wildCId = VGen (scopeSize scope) [] : env
| otherwise = env
in exScope (addScopedVar x (TTyp env ty) scope) env' hypos
mkEnv scope env [] = return (env,[])
mkEnv scope env ((bt,x,ty):hypos) = do
(env,arg) <- if x /= wildCId
then do i <- newMeta scope (TTyp env ty)
return (VMeta i (scopeEnv scope) [] : env,Right (EMeta i))
else return (env,Left (TTyp env ty))
(env,args) <- mkEnv scope env hypos
return (env,(bt,arg):args)
descend scope (bt,arg) = do
let dp' = fmap (flip (-) 1) dp
e <- case arg of
Right e -> return e
Left tty -> prove dp' scope tty
e <- case bt of
Implicit -> return (EImplArg e)
Explicit -> return e
return e
-- Helper function for random generation. After every
-- success we must restart the search to find sufficiently different solution.
restart :: RandomGen g => g -> (g -> [a]) -> [a]
restart g f =
let (g1,g2) = split g
in case f g1 of
[] -> []
(x:xs) -> x : restart g2 f
------------------------------------------------------------------------------
-- Selectors
instance Selector () where
splitSelector s = (s,s)
select cat scope dp = do
gens <- typeGenerators scope cat
TcM (\abstr k h -> iter k gens)
where
iter k [] ms s = id
iter k ((_,e,tty):fns) ms s = k (e,tty) ms s . iter k fns ms s
instance RandomGen g => Selector (Identity g) where
splitSelector (Identity g) = let (g1,g2) = split g
in (Identity g1, Identity g2)
select cat scope dp = do
gens <- typeGenerators scope cat
TcM (\abstr k h -> iter k 1.0 gens)
where
iter k p [] ms (Identity g) = id
iter k p gens ms (Identity g) = let (d,g') = randomR (0.0,p) g
(g1,g2) = split g'
(p',e_ty,gens') = hit d gens
in k e_ty ms (Identity g1) . iter k (p-p') gens' ms (Identity g2)
hit :: Double -> [(Double,Expr,TType)] -> (Double,(Expr,TType),[(Double,Expr,TType)])
hit d (gen@(p,e,ty):gens)
| d < p || null gens = (p,(e,ty),gens)
| otherwise = let (p',e_ty',gens') = hit (d-p) gens
in (p',e_ty',gen:gens')
data Ontology a = Ontology [(Maybe Expr, Type)] a
instance RandomGen g => Selector (Ontology g) where
splitSelector (Ontology args g) = let (g1,g2) = split g
in (Ontology args g1, Ontology args g2)
select cat scope dp = do
Ontology args g <- get
case pickArg [] cat args of
[] -> do gens <- typeGenerators scope cat
TcM (\abstr k h -> iter k 1.0 gens)
alts -> msum [ case mb_e of
Just e -> do put (Ontology args g)
return (e, TTyp [] ty)
Nothing -> mzero
| (mb_e,ty,args) <- alts]
where
iter k p [] ms (Ontology ce g) = id
iter k p gens ms (Ontology ce g) =
let (d,g') = randomR (0.0,p) g
(g1,g2) = split g'
(p',e_ty,gens') = hit d gens
in k e_ty ms (Ontology ce g1) . iter k (p-p') gens' ms (Ontology ce g2)
hit :: Double -> [(Double,Expr,TType)] -> (Double,(Expr,TType),[(Double,Expr,TType)])
hit d (gen@(p,e,ty):gens) | d < p || null gens = (p,(e,ty),gens)
| otherwise = let (p',e_ty',gens') = hit (d-p) gens
in (p',e_ty',gen:gens')
pickArg args' cat' [] = []
pickArg args' cat' (arg@(mb_e,ty@(DTyp _ cat _)):args)
| cat' == cat = (mb_e, ty, foldl (flip (:)) args args') :
pickArg (arg:args') cat' args
| otherwise = pickArg (arg:args') cat' args

79
src/runtime/haskell/PGF/Haskell.hs
View File

@@ -1,79 +0,0 @@
-- | Auxiliary types and functions for use with grammars translated to Haskell
-- with @gf -output-format=haskell -haskell=concrete@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
module PGF.Haskell where
import Control.Applicative((<$>),(<*>))
import Control.Monad(join)
import Data.Char(toUpper)
import Data.List(isPrefixOf)
import qualified Data.Map as M
-- ** Concrete syntax
-- | For enumerating parameter values used in tables
class EnumAll a where enumAll :: [a]
-- | Tables
table vs = let m = M.fromList (zip enumAll vs) in (M.!) m
-- | Token sequences, output form linearization functions
type Str = [Tok] -- token sequence
-- | Tokens
data Tok = TK String | TP [([Prefix],Str)] Str | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
deriving (Eq,Ord,Show)
type Prefix = String -- ^ To be matched with the prefix of a following token
-- | Render a token sequence as a 'String'
fromStr :: Str -> String
fromStr = from False id
where
from space cap ts =
case ts of
[] -> []
TK "":ts -> from space cap ts
TK s:ts -> put s++from True cap ts
BIND:ts -> from False cap ts
SOFT_BIND:ts -> from False cap ts
SOFT_SPACE:ts -> from True cap ts
CAPIT:ts -> from space toUpper1 ts
ALL_CAPIT:ts -> from space toUpperAll ts
TP alts def:ts -> from space cap (pick alts def r++[TK r]) -- hmm
where r = fromStr ts
where
put s = [' '|space]++cap s
toUpper1 (c:s) = toUpper c:s
toUpper1 s = s
toUpperAll = map toUpper
pick alts def r = head ([str|(ps,str)<-alts,any (`isPrefixOf` r) ps]++[def])
-- *** Common record types
-- | Overloaded function to project the @s@ field from any record type
class Has_s r a | r -> a where proj_s :: r -> a
-- | Haskell representation of the GF record type @{s:t}@
data R_s t = R_s t deriving (Eq,Ord,Show)
instance (EnumAll t) => EnumAll (R_s t) where enumAll = R_s <$> enumAll
instance Has_s (R_s t) t where proj_s (R_s t) = t
-- | Coerce from any record type @{...,s:t,...}@ to the supertype @{s:t}@
to_R_s r = R_s (proj_s r)
-- *** Variants
infixr 5 +++
-- | Concatenation with variants
xs +++ ys = (++) <$> xs <*> ys
-- | Selection from tables with variants
t ! p = join (t p)
t !$ p = join (t <$> p)
t !* p = join (t <*> p)

276
src/runtime/haskell/PGF/Internal.hs
View File

@@ -1,169 +1,163 @@
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE ImplicitParams, RankNTypes #-}
-------------------------------------------------
-- |
-- Stability : unstable
--
-------------------------------------------------
module PGF.Internal(CId,Language,PGF,
Concr,lookConcr,
FId,isPredefFId,
FunId,SeqId,LIndex,Token,
Production(..),PArg(..),Symbol(..),Literal(..),BindType(..),PGF.Internal.Sequence,
{-# LANGUAGE ImplicitParams #-}
module PGF.Internal(CId(..),Language,PGF2.PGF,
PGF2.Concr,lookConcr,
PGF2.FId,isPredefFId,
PGF2.FunId,PGF2.SeqId,PGF2.LIndex,PGF2.Token,
PGF2.Production(..),PGF2.PArg(..),PGF2.Symbol(..),PGF2.Literal(..),PGF2.BindType(..),Sequence,
globalFlags, abstrFlags, concrFlags,
concrTotalCats, concrCategories, concrProductions,
concrTotalFuns, concrFunction,
concrTotalSeqs, concrSequence,
CodeLabel, Instr(..), IVal(..), TailInfo(..),
Builder, B, build,
eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo,
AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF,
dTyp, hypo,
fidString, fidInt, fidFloat, fidVar, fidStart,
ppFunId, ppSeqId, ppFId, ppMeta, ppLit, PGF.Internal.ppSeq
) where
PGF2.CodeLabel, PGF2.Instr(..), PGF2.IVal(..), PGF2.TailInfo(..),
import PGF.Data
import PGF.Macros
import PGF.Printer
import PGF.ByteCode
PGF2.Builder, PGF2.B, PGF2.build,
eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo,
PGF2.AbstrInfo, newAbstr, PGF2.ConcrInfo, newConcr, newPGF,
-- * Write an in-memory PGF to a file
writePGF, writeConcr,
PGF2.fidString, PGF2.fidInt, PGF2.fidFloat, PGF2.fidVar, PGF2.fidStart,
ppFunId, ppSeqId, ppFId, ppMeta, ppLit, ppSeq,
unionPGF
) where
import qualified PGF2
import qualified PGF2.Internal as PGF2
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import PGF2.FFI(PGF(..))
import Data.Array.IArray
import Data.Array.Unboxed
import Text.PrettyPrint
globalFlags pgf = gflags pgf
abstrFlags pgf = aflags (abstract pgf)
concrFlags concr = cflags concr
newtype CId = CId String deriving (Show,Read,Eq,Ord)
concrTotalCats = totalCats
type Language = CId
concrCategories :: Concr -> [(CId,FId,FId,[String])]
concrCategories c = [(cat,start,end,elems lbls) | (cat,CncCat start end lbls) <- Map.toList (cnccats c)]
lookConcr (PGF _ langs _) (CId lang) =
case Map.lookup lang langs of
Just cnc -> cnc
Nothing -> error "Unknown language"
concrTotalFuns c =
let (s,e) = bounds (cncfuns c)
in e-s+1
globalFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.globalFlags pgf]
abstrFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.abstrFlags pgf]
concrFlags concr = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.concrFlags concr]
concrFunction :: Concr -> FunId -> (CId,[SeqId])
concrFunction c funid =
let CncFun fun lins = cncfuns c ! funid
in (fun,elems lins)
concrTotalCats = PGF2.concrTotalCats
concrTotalSeqs :: Concr -> SeqId
concrTotalSeqs c =
let (s,e) = bounds (sequences c)
in e-s+1
concrCategories :: PGF2.Concr -> [(CId,PGF2.FId,PGF2.FId,[String])]
concrCategories c = [(CId cat,start,end,lbls) | (cat,start,end,lbls) <- PGF2.concrCategories c]
type Sequence = [Symbol]
concrProductions :: PGF2.Concr -> PGF2.FId -> [PGF2.Production]
concrProductions = PGF2.concrProductions
concrSequence :: Concr -> SeqId -> [Symbol]
concrSequence c seqid = elems (sequences c ! seqid)
concrTotalFuns = PGF2.concrTotalFuns
concrProductions :: Concr -> FId -> [Production]
concrProductions c fid =
case IntMap.lookup fid (productions c) of
Just set -> Set.toList set
Nothing -> []
concrFunction :: PGF2.Concr -> PGF2.FunId -> (CId,[PGF2.SeqId])
concrFunction c funid =
let (fun,seqids) = PGF2.concrFunction c funid
in (CId fun,seqids)
concrTotalSeqs :: PGF2.Concr -> PGF2.SeqId
concrTotalSeqs = PGF2.concrTotalSeqs
concrSequence = PGF2.concrSequence
isPredefFId = PGF2.isPredefFId
type Sequence = [PGF2.Symbol]
eAbs :: (?builder :: PGF2.Builder s) => PGF2.BindType -> CId -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
eAbs bind_type (CId var) body = PGF2.eAbs bind_type var body
eApp :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
eApp = PGF2.eApp
eMeta :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
eMeta = PGF2.eMeta
eFun (CId fun) = PGF2.eFun fun
eVar :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
eVar = PGF2.eVar
eLit :: (?builder :: PGF2.Builder s) => PGF2.Literal -> PGF2.B s PGF2.Expr
eLit = PGF2.eLit
eTyped :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Type -> PGF2.B s PGF2.Expr
eTyped = PGF2.eTyped
eImplArg :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
eImplArg = PGF2.eImplArg
dTyp :: (?builder :: PGF2.Builder s) => [PGF2.B s (PGF2.BindType,String,PGF2.Type)] -> CId -> [PGF2.B s PGF2.Expr] -> PGF2.B s PGF2.Type
dTyp hypos (CId cat) es = PGF2.dTyp hypos cat es
hypo bind_type (CId var) ty = PGF2.hypo bind_type var ty
newAbstr flags cats funs = PGF2.newAbstr [(flag,lit) | (CId flag,lit) <- flags]
[(cat,hypos,prob) | (CId cat,hypos,prob) <- cats]
[(fun,ty,arity,prob) | (CId fun,ty,arity,prob) <- funs]
newConcr abs flags printnames lindefs linrefs prods cncfuns seqs cnccats total_ccats =
PGF2.newConcr abs [(flag,lit) | (CId flag,lit) <- flags]
[(id,name) | (CId id,name) <- printnames]
lindefs linrefs
prods
[(fun,seq_ids) | (CId fun,seq_ids) <- cncfuns]
seqs
[(cat,start,end,labels) | (CId cat,start,end,labels) <- cnccats]
total_ccats
newPGF flags (CId name) abstr concrs =
PGF2.newPGF [(flag,lit) | (CId flag,lit) <- flags]
name
abstr
[(name,concr) | (CId name,concr) <- concrs]
writePGF = PGF2.writePGF
writeConcr fpath pgf lang = PGF2.writeConcr fpath (lookConcr pgf lang)
data Builder s
newtype B s a = B a
ppFunId funid = char 'F' <> int funid
ppSeqId seqid = char 'S' <> int seqid
build :: (forall s . (?builder :: Builder s) => B s a) -> a
build x = let ?builder = undefined
in case x of
B x -> x
ppFId fid
| fid == PGF2.fidString = text "CString"
| fid == PGF2.fidInt = text "CInt"
| fid == PGF2.fidFloat = text "CFloat"
| fid == PGF2.fidVar = text "CVar"
| fid == PGF2.fidStart = text "CStart"
| otherwise = char 'C' <> int fid
eAbs :: (?builder :: Builder s) => BindType -> CId -> B s Expr -> B s Expr
eAbs bind_type var (B body) = B (EAbs bind_type var body)
ppMeta :: Int -> Doc
ppMeta n
| n == 0 = char '?'
| otherwise = char '?' <> int n
eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr
eApp (B f) (B x) = B (EApp f x)
ppLit (PGF2.LStr s) = text (show s)
ppLit (PGF2.LInt n) = int n
ppLit (PGF2.LFlt d) = double d
eMeta :: (?builder :: Builder s) => Int -> B s Expr
eMeta i = B (EMeta i)
ppSeq (seqid,seq) =
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol seq)
eFun :: (?builder :: Builder s) => CId -> B s Expr
eFun f = B (EFun f)
ppSymbol (PGF2.SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (PGF2.SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
ppSymbol (PGF2.SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
ppSymbol (PGF2.SymKS t) = doubleQuotes (text t)
ppSymbol PGF2.SymNE = text "nonExist"
ppSymbol PGF2.SymBIND = text "BIND"
ppSymbol PGF2.SymSOFT_BIND = text "SOFT_BIND"
ppSymbol PGF2.SymSOFT_SPACE= text "SOFT_SPACE"
ppSymbol PGF2.SymCAPIT = text "CAPIT"
ppSymbol PGF2.SymALL_CAPIT = text "ALL_CAPIT"
ppSymbol (PGF2.SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
eVar :: (?builder :: Builder s) => Int -> B s Expr
eVar i = B (EVar i)
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
eLit :: (?builder :: Builder s) => Literal -> B s Expr
eLit l = B (ELit l)
unionPGF = PGF2.unionPGF
eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr
eTyped (B e) (B ty) = B (ETyped e ty)
eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr
eImplArg (B e) = B (EImplArg e)
hypo :: BindType -> CId -> B s Type -> (B s Hypo)
hypo bind_type var (B ty) = B (bind_type,var,ty)
dTyp :: (?builder :: Builder s) => [B s Hypo] -> CId -> [B s Expr] -> B s Type
dTyp hypos cat es = B (DTyp [hypo | B hypo <- hypos] cat [e | B e <- es])
type AbstrInfo = Abstr
newAbstr :: (?builder :: Builder s) => [(CId,Literal)] ->
[(CId,[B s Hypo],Float)] ->
[(CId,B s Type,Int,Float)] ->
B s AbstrInfo
newAbstr aflags cats funs = B (Abstr (Map.fromList aflags)
(Map.fromList [(fun,(ty,arity,Nothing,realToFrac prob)) | (fun,B ty,arity,prob) <- funs])
(Map.fromList [(cat,([hypo | B hypo <- hypos],[],realToFrac prob)) | (cat,hypos,prob) <- cats]))
type ConcrInfo = Concr
newConcr :: (?builder :: Builder s) => B s AbstrInfo ->
[(CId,Literal)] -> -- ^ Concrete syntax flags
[(CId,String)] -> -- ^ Printnames
[(FId,[FunId])] -> -- ^ Lindefs
[(FId,[FunId])] -> -- ^ Linrefs
[(FId,[Production])] -> -- ^ Productions
[(CId,[SeqId])] -> -- ^ Concrete functions (must be sorted by Fun)
[[Symbol]] -> -- ^ Sequences (must be sorted)
[(CId,FId,FId,[String])] -> -- ^ Concrete categories
FId -> -- ^ The total count of the categories
B s ConcrInfo
newConcr _ cflags printnames lindefs linrefs productions cncfuns sequences cnccats totalCats =
B (Concr {cflags = Map.fromList cflags
,printnames = Map.fromList printnames
,lindefs = IntMap.fromList lindefs
,linrefs = IntMap.fromList linrefs
,productions = IntMap.fromList [(fid,Set.fromList prods) | (fid,prods) <- productions]
,cncfuns = mkArray [CncFun fun (mkArray lins) | (fun,lins) <- cncfuns]
,sequences = mkArray (map mkArray sequences)
,cnccats = Map.fromList [(cat,CncCat s e (mkArray lbls)) | (cat,s,e,lbls) <- cnccats]
,totalCats = totalCats
})
{-
pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing
lproductions :: Map.Map CId (IntMap.IntMap (Set.Set Production)), -- productions needed for linearization
lexicon :: IntMap.IntMap (IntMap.IntMap (TMap.TrieMap Token IntSet.IntSet)),
-}
newPGF :: (?builder :: Builder s) => [(CId,Literal)] ->
CId ->
B s AbstrInfo ->
[(CId,B s ConcrInfo)] ->
B s PGF
newPGF gflags absname (B abstract) concretes =
B (PGF {gflags = Map.fromList gflags
,absname = absname
,abstract = abstract
,concretes = Map.fromList [(cname,concr) | (cname,B concr) <- concretes]
})
ppSeq (seqid,seq) = PGF.Printer.ppSeq (seqid,mkArray seq)
mkArray l = listArray (0,length l-1) l

128
src/runtime/haskell/PGF/Linearize.hs
View File

@@ -1,128 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
module PGF.Linearize
( linearize
, linearizeAll
, linearizeAllLang
, bracketedLinearize
, tabularLinearizes
) where
import PGF.CId
import PGF.Data
import PGF.Macros
import PGF.Expr
import Data.Array.IArray
import Data.List
--import Control.Monad
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
--------------------------------------------------------------------
-- The API
--------------------------------------------------------------------
-- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Tree -> String
linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
where
cnc = lookMap (error "no lang") lang (concretes pgf)
-- | The same as 'linearizeAllLang' but does not return
-- the language.
linearizeAll :: PGF -> Tree -> [String]
linearizeAll pgf = map snd . linearizeAllLang pgf
-- | Linearizes given expression as string in all languages
-- available in the grammar.
linearizeAllLang :: PGF -> Tree -> [(Language,String)]
linearizeAllLang pgf t = [(lang,linearize pgf lang t) | lang <- Map.keys (concretes pgf)]
-- | Linearizes given expression as a bracketed string in the language
bracketedLinearize :: PGF -> Language -> Tree -> [BracketedString]
bracketedLinearize pgf lang = head . map (snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
where
cnc = lookMap (error "no lang") lang (concretes pgf)
head [] = []
head (bs:bss) = bs
firstLin cnc arg@(ct@(cat,n_fid),fid,fun,es,(xs,lin)) =
case IntMap.lookup fid (linrefs cnc) of
Just (funid:_) -> snd (mkLinTable cnc (const True) [] funid [arg]) ! 0
_ -> [LeafKS []]
-- | Creates a table from feature name to linearization.
-- The outher list encodes the variations
tabularLinearizes :: PGF -> Language -> Expr -> [[(String,String)]]
tabularLinearizes pgf lang e = map cnv (linTree pgf cnc e)
where
cnc = lookMap (error "no lang") lang (concretes pgf)
cnv (ct@(cat,_),_,_,_,(_,lin)) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn Nothing) (elems lin)
lbls cat = case Map.lookup cat (cnccats (lookConcr pgf lang)) of
Just (CncCat _ _ lbls) -> elems lbls
Nothing -> error "No labels"
--------------------------------------------------------------------
-- Implementation
--------------------------------------------------------------------
linTree :: PGF -> Concr -> Expr -> [(CncType, FId, CId, [Expr], LinTable)]
linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
where
lp = lproductions cnc
lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es
lin mb_cty n_fid e0 ys xs (EApp e1 e2) es = lin mb_cty n_fid e0 ys xs e1 (e2:es)
lin mb_cty n_fid e0 ys xs (EImplArg e) es = lin mb_cty n_fid e0 ys xs e es
lin mb_cty n_fid e0 ys xs (ETyped e _) es = lin mb_cty n_fid e0 ys xs e es
lin mb_cty n_fid e0 ys xs (EFun f) es = apply mb_cty n_fid e0 ys xs f es
lin mb_cty n_fid e0 ys xs (EMeta i) es = def mb_cty n_fid e0 ys xs ('?':show i)
lin mb_cty n_fid e0 ys xs (EVar i) _ = def mb_cty n_fid e0 ys xs (showCId ((xs++ys) !! i))
lin mb_cty n_fid e0 ys xs (ELit l) [] = case l of
LStr s -> return (n_fid+1,((cidString,n_fid),fidString,wildCId,[e0],([],ss s)))
LInt n -> return (n_fid+1,((cidInt, n_fid),fidInt, wildCId,[e0],([],ss (show n))))
LFlt f -> return (n_fid+1,((cidFloat, n_fid),fidFloat, wildCId,[e0],([],ss (show f))))
ss s = listArray (0,0) [[LeafKS s]]
apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, FId, CId, [Expr], LinTable))]
apply mb_cty n_fid e0 ys xs f es =
case Map.lookup f lp of
Just prods -> do (funid,(cat,fid),ctys) <- getApps prods
(n_fid,args) <- descend n_fid (zip ctys es)
return (n_fid+1,((cat,n_fid),fid,f,[e0],mkLinTable cnc (const True) xs funid args))
Nothing -> def mb_cty n_fid e0 ys xs ("[" ++ showCId f ++ "]") -- fun without lin
where
getApps prods =
case mb_cty of
Just (cat,fid) -> maybe [] (concatMap (toApp fid) . Set.toList) (IntMap.lookup fid prods)
Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
where
toApp fid (PApply funid pargs) =
let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))
(args,res) = catSkeleton ty
in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
toApp _ (PCoerce fid) =
maybe [] (concatMap (toApp fid) . Set.toList) (IntMap.lookup fid prods)
descend n_fid [] = return (n_fid,[])
descend n_fid ((cty,e):fes) = do (n_fid,arg) <- lin (Just cty) n_fid e (xs++ys) [] e []
(n_fid,args) <- descend n_fid fes
return (n_fid,arg:args)
def (Just (cat,fid)) n_fid e0 ys xs s =
case IntMap.lookup fid (lindefs cnc) of
Just funs -> do funid <- funs
let args = [((wildCId, n_fid),fidString,wildCId,[e0],([],ss s))]
return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],mkLinTable cnc (const True) xs funid args))
Nothing
| isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
| otherwise -> do PCoerce fid <- maybe [] Set.toList (IntMap.lookup fid (pproductions cnc))
def (Just (cat,fid)) n_fid e0 ys xs s
def Nothing n_fid e0 ys xs s = []
--amapWithIndex :: (IArray a e1, IArray a e2, Ix i) => (i -> e1 -> e2) -> a i e1 -> a i e2
--amapWithIndex f arr = listArray (bounds arr) (map (uncurry f) (assocs arr))

242
src/runtime/haskell/PGF/Macros.hs
View File

@@ -1,242 +0,0 @@
module PGF.Macros where
import PGF.CId
import PGF.Data
import Control.Monad
import qualified Data.Map as Map
--import qualified Data.Set as Set
--import qualified Data.IntMap as IntMap
--import qualified Data.IntSet as IntSet
import qualified Data.Array as Array
--import Data.Maybe
import Data.List
import Data.Array.IArray
import Text.PrettyPrint
-- operations for manipulating PGF grammars and objects
mapConcretes :: (Concr -> Concr) -> PGF -> PGF
mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
lookType :: Abstr -> CId -> Type
lookType abs f =
case lookMap (error $ "lookType " ++ show f) f (funs abs) of
(ty,_,_,_) -> ty
isData :: Abstr -> CId -> Bool
isData abs f =
case Map.lookup f (funs abs) of
Just (_,_,Nothing,_) -> True -- the encoding of data constrs
_ -> False
lookValCat :: Abstr -> CId -> CId
lookValCat abs = valCat . lookType abs
lookStartCat :: PGF -> CId
lookStartCat pgf = mkCId $
case msum $ Data.List.map (Map.lookup (mkCId "startcat")) [gflags pgf, aflags (abstract pgf)] of
Just (LStr s) -> s
_ -> "S"
lookGlobalFlag :: PGF -> CId -> Maybe Literal
lookGlobalFlag pgf f = Map.lookup f (gflags pgf)
lookAbsFlag :: PGF -> CId -> Maybe Literal
lookAbsFlag pgf f = Map.lookup f (aflags (abstract pgf))
lookConcr :: PGF -> Language -> Concr
lookConcr pgf cnc =
lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf
-- use if name fails, use abstract + name; so e.g. "Eng" becomes "DemoEng"
lookConcrComplete :: PGF -> CId -> Concr
lookConcrComplete pgf cnc =
case Map.lookup cnc (concretes pgf) of
Just c -> c
_ -> lookConcr pgf (mkCId (showCId (absname pgf) ++ showCId cnc))
lookConcrFlag :: PGF -> CId -> CId -> Maybe Literal
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 ([],[],0) cat $ cats $ abstract pgf
-- | List of functions that lack linearizations in the given language.
missingLins :: PGF -> Language -> [CId]
missingLins pgf lang = [c | c <- fs, not (hasl c)] where
fs = Map.keys $ funs $ abstract pgf
hasl = hasLin pgf lang
hasLin :: PGF -> Language -> CId -> Bool
hasLin pgf lang f = Map.member f $ lproductions $ lookConcr pgf lang
restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf {
abstract = abstr {
funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
cats = Map.map (\(hyps,fs,p) -> (hyps,filter (cond . snd) fs,p)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where
abstr = abstract pgf
depth :: Expr -> Int
depth (EAbs _ _ t) = depth t
depth (EApp e1 e2) = max (depth e1) (depth e2) + 1
depth _ = 1
cftype :: [CId] -> CId -> Type
cftype args val = DTyp [(Explicit,wildCId,cftype [] arg) | arg <- args] val []
typeOfHypo :: Hypo -> Type
typeOfHypo (_,_,ty) = ty
catSkeleton :: Type -> ([CId],CId)
catSkeleton ty = case ty of
DTyp hyps val _ -> ([valCat (typeOfHypo h) | h <- hyps],val)
typeSkeleton :: Type -> ([(Int,CId)],CId)
typeSkeleton ty = case ty of
DTyp hyps val _ -> ([(contextLength ty, valCat ty) | h <- hyps, let ty = typeOfHypo h],val)
valCat :: Type -> CId
valCat ty = case ty of
DTyp _ val _ -> val
contextLength :: Type -> Int
contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
-- | Show the printname of function or category
showPrintName :: PGF -> Language -> CId -> String
showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
-- lookup with default value
lookMap :: Ord i => a -> i -> Map.Map i a -> a
lookMap d c m = Map.findWithDefault d c m
--- from Operations
combinations :: [[a]] -> [[a]]
combinations t = case t of
[] -> [[]]
aa:uu -> [a:u | a <- aa, u <- combinations uu]
cidString = mkCId "String"
cidInt = mkCId "Int"
cidFloat = mkCId "Float"
cidVar = mkCId "__gfVar"
-- Utilities for doing linearization
-- | BracketedString represents a sentence that is linearized
-- as usual but we also want to retain the ''brackets'' that
-- mark the beginning and the end of each constituent.
data BracketedString
= Leaf Token -- ^ this is the leaf i.e. a single token
| Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedString]
-- ^ this is a bracket. The 'CId' is the category of
-- the phrase. The 'FId' is an unique identifier for
-- every phrase in the sentence. For context-free grammars
-- i.e. without discontinuous constituents this identifier
-- is also unique for every bracket. When there are discontinuous
-- phrases then the identifiers are unique for every phrase but
-- not for every bracket since the bracket represents a constituent.
-- The different constituents could still be distinguished by using
-- the constituent index i.e. 'LIndex'. If the grammar is reduplicating
-- then the constituent indices will be the same for all brackets
-- that represents the same constituent.
data BracketedTokn
= Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn] -- Invariant: the list is not empty
| LeafKS Token
| LeafNE
| LeafBIND
| LeafSOFT_BIND
| LeafCAPIT
| LeafKP [BracketedTokn] [([BracketedTokn],[String])]
deriving Eq
type LinTable = ([CId],Array.Array LIndex [BracketedTokn])
-- | Renders the bracketed string as string where
-- the brackets are shown as @(S ...)@ where
-- @S@ is the category.
showBracketedString :: BracketedString -> String
showBracketedString = render . ppBracketedString
ppBracketedString (Leaf t) = text t
ppBracketedString (Bracket cat fid fid' index _ _ bss) = parens (ppCId cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
-- | The length of the bracketed string in number of tokens.
lengthBracketedString :: BracketedString -> Int
lengthBracketedString (Leaf _) = 1
lengthBracketedString (Bracket _ _ _ _ _ _ bss) = sum (map lengthBracketedString bss)
untokn :: Maybe String -> [BracketedTokn] -> (Maybe String,[BracketedString])
untokn nw bss =
let (nw',bss') = mapAccumR untokn nw bss
in case sequence bss' of
Just bss -> (nw,concat bss)
Nothing -> (nw,[])
where
untokn nw (Bracket_ cat fid fid' index fun es bss) =
let (nw',bss') = mapAccumR untokn nw bss
in case sequence bss' of
Just bss -> (nw',Just [Bracket cat fid fid' index fun es (concat bss)])
Nothing -> (Nothing, Nothing)
untokn nw (LeafKS t)
| null t = (nw,Just [])
| otherwise = (Just t,Just [Leaf t])
untokn nw LeafNE = (Nothing, Nothing)
untokn nw (LeafKP d vs) = let (nw',bss') = mapAccumR untokn nw (sel d vs nw)
in case sequence bss' of
Just bss -> (nw',Just (concat bss))
Nothing -> (Nothing, Nothing)
where
sel d vs Nothing = d
sel d vs (Just w) =
case [v | (v,cs) <- vs, any (\c -> isPrefixOf c w) cs] of
v:_ -> v
_ -> d
type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id
mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,FId,CId,[Expr],LinTable)] -> LinTable
mkLinTable cnc filter xs funid args = (xs,listArray (bounds lins) [computeSeq filter (elems (sequences cnc ! seqid)) args | seqid <- elems lins])
where
(CncFun _ lins) = cncfuns cnc ! funid
computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,FId,CId,[Expr],LinTable)] -> [BracketedTokn]
computeSeq filter seq args = concatMap compute seq
where
compute (SymCat d r) = getArg d r
compute (SymLit d r) = getArg d r
compute (SymVar d r) = getVar d r
compute (SymKS t) = [LeafKS t]
compute SymNE = [LeafNE]
compute SymBIND = [LeafKS "&+"]
compute SymSOFT_BIND = []
compute SymSOFT_SPACE = []
compute SymCAPIT = [LeafKS "&|"]
compute SymALL_CAPIT = [LeafKS "&|"]
compute (SymKP syms alts) = [LeafKP (concatMap compute syms) [(concatMap compute syms,cs) | (syms,cs) <- alts]]
getArg d r
| not (null arg_lin) &&
filter ct = [Bracket_ cat fid fid' r fun es arg_lin]
| otherwise = arg_lin
where
arg_lin = lin ! r
(ct@(cat,fid),fid',fun,es,(_xs,lin)) = args !! d
getVar d r = [LeafKS (showCId (xs !! r))]
where
(_ct,_,_fun,_es,(xs,_lin)) = args !! d
flattenBracketedString :: BracketedString -> [String]
flattenBracketedString (Leaf w) = [w]
flattenBracketedString (Bracket _ _ _ _ _ _ bss) = concatMap flattenBracketedString bss

66
src/runtime/haskell/PGF/Morphology.hs
View File

@@ -1,66 +0,0 @@
module PGF.Morphology(Lemma,Analysis,Morpho,
buildMorpho,isInMorpho,
lookupMorpho,fullFormLexicon,
morphoMissing,morphoKnown,morphoClassify,
missingWordMsg) where
import PGF.CId
import PGF.Data
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import Data.Array.IArray
--import Data.List (intersperse)
import Data.Char (isDigit) ----
-- these 4 definitions depend on the datastructure used
type Lemma = CId
type Analysis = String
newtype Morpho = Morpho (Map.Map String [(Lemma,Analysis)])
buildMorpho :: PGF -> Language -> Morpho
buildMorpho pgf lang = Morpho $
case Map.lookup lang (concretes pgf) of
Just pinfo -> collectWords pinfo
Nothing -> Map.empty
collectWords pinfo = Map.fromListWith (++)
[(t, [(fun,lbls ! l)]) | (CncCat s e lbls) <- Map.elems (cnccats pinfo)
, fid <- [s..e]
, PApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (productions pinfo))
, let CncFun fun lins = cncfuns pinfo ! funid
, (l,seqid) <- assocs lins
, sym <- elems (sequences pinfo ! seqid)
, t <- sym2tokns sym]
where
sym2tokns (SymKS t) = [t]
sym2tokns (SymKP ts alts) = concat (map sym2tokns ts ++ [sym2tokns sym | (syms,ps) <- alts, sym <- syms])
sym2tokns _ = []
lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo
isInMorpho :: Morpho -> String -> Bool
isInMorpho (Morpho mo) s = maybe False (const True) $ Map.lookup s mo
fullFormLexicon :: Morpho -> [(String,[(Lemma,Analysis)])]
fullFormLexicon (Morpho mo) = Map.toList mo
morphoMissing :: Morpho -> [String] -> [String]
morphoMissing = morphoClassify False
morphoKnown :: Morpho -> [String] -> [String]
morphoKnown = morphoClassify True
morphoClassify :: Bool -> Morpho -> [String] -> [String]
morphoClassify k mo ws = [w | w <- ws, k /= null (lookupMorpho mo w), notLiteral w] where
notLiteral w = not (all isDigit w) ---- should be defined somewhere
missingWordMsg :: Morpho -> [String] -> String
missingWordMsg morpho ws = case morphoMissing morpho ws of
[] -> ", but all words are known"
ws -> "; unknown words: " ++ unwords ws

181
src/runtime/haskell/PGF/OldBinary.hs
View File

@@ -1,181 +0,0 @@
-- | Read PGF files created with GF 3.5 and a few older releases
module PGF.OldBinary(getPGF,getPGF',version) where
import PGF.CId
import PGF.Data
import PGF.Optimize
import Data.Binary
import Data.Binary.Get
import Data.Array.IArray
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Control.Monad
pgfMajorVersion, pgfMinorVersion :: Word16
version@(pgfMajorVersion, pgfMinorVersion) = (1,0)
getPGF = do v1 <- getWord16be
v2 <- getWord16be
let v=(v1,v2)
if v==version
then getPGF'
else decodingError ("version "++show v++"/="++show version)
getPGF'=do gflags <- getFlags
absname <- getCId
abstract <- getAbstract
concretes <- getMap getCId getConcr
return $ updateProductionIndices $
(PGF{ gflags=gflags
, absname=absname, abstract=abstract
, concretes=concretes
})
getCId = liftM CId get
getAbstract =
do aflags <- getFlags
funs <- getMap getCId getFun
cats <- getMap getCId getCat
return (Abstr{ aflags=aflags
, funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs
, cats=fmap (\(x,y) -> (x,y,0)) cats
})
getFun :: Get (Type,Int,Maybe [Equation],Double)
getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get
getCat :: Get ([Hypo],[(Double, CId)])
getCat = getPair (getList getHypo) (getList (getPair get getCId))
getFlags = getMap getCId getLiteral
getConcr =
do cflags <- getFlags
printnames <- getMap getCId get
(scnt,seqs) <- getList' getSequence
(fcnt,cncfuns) <- getList' getCncFun
lindefs <- get
productions <- getIntMap (getSet getProduction)
cnccats <- getMap getCId getCncCat
totalCats <- get
let rseq = listToArray [SymCat 0 0]
rfun = CncFun (mkCId "linref") (listToArray [scnt])
linrefs = IntMap.fromList [(i,[fcnt])|i<-[0..totalCats-1]]
return (Concr{ cflags=cflags, printnames=printnames
, sequences=toArray (scnt+1,seqs++[rseq])
, cncfuns=toArray (fcnt+1,cncfuns++[rfun])
, lindefs=lindefs, linrefs=linrefs
, productions=productions
, pproductions = IntMap.empty
, lproductions = Map.empty
, lexicon = IntMap.empty
, cnccats=cnccats, totalCats=totalCats
})
getExpr =
do tag <- getWord8
case tag of
0 -> liftM3 EAbs getBindType getCId getExpr
1 -> liftM2 EApp getExpr getExpr
2 -> liftM ELit getLiteral
3 -> liftM EMeta get
4 -> liftM EFun getCId
5 -> liftM EVar get
6 -> liftM2 ETyped getExpr getType
7 -> liftM EImplArg getExpr
_ -> decodingError "getExpr"
getPatt =
do tag <- getWord8
case tag of
0 -> liftM2 PApp getCId (getList getPatt)
1 -> liftM PVar getCId
2 -> liftM2 PAs getCId getPatt
3 -> return PWild
4 -> liftM PLit getLiteral
5 -> liftM PImplArg getPatt
6 -> liftM PTilde getExpr
_ -> decodingError "getPatt"
getEquation = liftM2 Equ (getList getPatt) getExpr
getType = liftM3 DTyp (getList getHypo) getCId (getList getExpr)
getHypo = (,,) `fmap` getBindType `ap` getCId `ap` getType
getBindType =
do tag <- getWord8
case tag of
0 -> return Explicit
1 -> return Implicit
_ -> decodingError "getBindType"
getCncFun = liftM2 CncFun getCId (getArray get)
getCncCat = liftM3 CncCat get get (getArray get)
getSequence = listToArray `fmap` getSymbols
getSymbols = concat `fmap` getList getSymbol
getSymbol :: Get [Symbol]
getSymbol =
do tag <- getWord8
case tag of
0 -> (:[]) `fmap` liftM2 SymCat get get
1 -> (:[]) `fmap` liftM2 SymLit get get
2 -> (:[]) `fmap` liftM2 SymVar get get
3 -> liftM (map SymKS) get
4 -> (:[]) `fmap` liftM2 SymKP (getList getTokenSymbol) getAlternatives
_ -> decodingError ("getSymbol "++show tag)
getAlternatives = getList (getPair (getList getTokenSymbol) get)
:: Get [([Symbol],[String])]
getTokenSymbol = fmap SymKS get
--getTokens = unwords `fmap` get
getPArg = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid)
getProduction =
do tag <- getWord8
case tag of
0 -> liftM2 PApply get (getList getPArg)
1 -> liftM PCoerce get
_ -> decodingError "getProduction"
getLiteral =
do tag <- getWord8
case tag of
0 -> liftM LStr get
1 -> liftM LInt get
2 -> liftM LFlt get
_ -> decodingError "getLiteral"
getArray :: IArray a e => Get e -> Get (a Int e)
getArray get1 = toArray `fmap` getList' get1
toArray (n,xs) = listArray (0::Int,n-1) xs
listToArray xs = toArray (length xs,xs)
--getArray2 :: (IArray a1 (a2 Int e), IArray a2 e) => Get e -> Get (a1 Int (a2 Int e))
--getArray2 get1 = getArray (getArray get1)
getList get1 = snd `fmap` getList' get1
getList' get1 = do n <- get :: Get Int
xs <- replicateM n get1
return (n,xs)
getMaybe get1 =
do isJust <- get
if isJust then fmap Just get1 else return Nothing
getMap getK getV = Map.fromDistinctAscList `fmap` getList (getPair getK getV)
getIntMap getV = IntMap.fromDistinctAscList `fmap` getList (getPair get getV)
getSet getV = Set.fromDistinctAscList `fmap` getList getV
getPair get1 get2 = (,) `fmap` get1 `ap` get2
decodingError explain = fail $ "Unable to read PGF file ("++explain++")"

113
src/runtime/haskell/PGF/Paraphrase.hs
View File

@@ -1,113 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Paraphrase
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- Generate parapharases with def definitions.
-----------------------------------------------------------------------------
module PGF.Paraphrase (
paraphrase,
paraphraseN
) where
import PGF.Data
import PGF.Tree
--import PGF.Macros (lookDef,isData)
--import PGF.CId
import Data.List (nub,sort,group)
import qualified Data.Map as Map
--import Debug.Trace ----
paraphrase :: PGF -> Expr -> [Expr]
paraphrase pgf t = nub (paraphraseN 2 pgf t)
paraphraseN :: Int -> PGF -> Expr -> [Expr]
paraphraseN i pgf = map tree2expr . paraphraseN' i pgf . expr2tree
paraphraseN' :: Int -> PGF -> Tree -> [Tree]
paraphraseN' 0 _ t = [t]
paraphraseN' i pgf t =
step i t ++ [Fun g ts' | Fun g ts <- step (i-1) t, ts' <- sequence (map par ts)]
where
par = paraphraseN' (i-1) pgf
step 0 t = [t]
step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept]
def = fromDef pgf
fromDef :: PGF -> Tree -> [Tree]
fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where
defDown t = [subst g u | let equ = equsFrom f, (u,g) <- match equ ts, trequ "U" f equ]
defUp t = [subst g u | equ <- equsTo f, (u,g) <- match [equ] ts, trequ "D" f equ]
equsFrom f = [(ps,d) | Just equs <- [lookup f equss], (Fun _ ps,d) <- equs]
equsTo f = [c | (_,equs) <- equss, c <- casesTo f equs]
casesTo f equs =
[(ps,p) | (p,d@(Fun g ps)) <- equs, g==f,
isClosed d || (length equs == 1 && isLinear d)]
equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) |
(f,(_,_,Just (eqs,_),_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs;
---- cf. PGF.Tree.expr2tree
trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True
subst :: Subst -> Tree -> Tree
subst g e = case e of
Fun f ts -> Fun f (map substg ts)
Var x -> maybe e id $ lookup x g
_ -> e
where
substg = subst g
type Subst = [(CId,Tree)]
-- this applies to pattern, hence don't need to consider abstractions
isClosed :: Tree -> Bool
isClosed t = case t of
Fun _ ts -> all isClosed ts
Var _ -> False
_ -> True
-- this applies to pattern, hence don't need to consider abstractions
isLinear :: Tree -> Bool
isLinear = nodup . vars where
vars t = case t of
Fun _ ts -> concatMap vars ts
Var x -> [x]
_ -> []
nodup = all ((<2) . length) . group . sort
match :: [([Tree],Tree)] -> [Tree] -> [(Tree, Subst)]
match cases terms = case cases of
[] -> []
(patts,_):_ | length patts /= length terms -> []
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Just substs -> return (val, concat substs)
_ -> match cc terms
where
tryMatch (p,t) = case (p, t) of
(Var x, _) | notMeta t -> return [(x,t)]
(Fun p pp, Fun f tt) | p == f && length pp == length tt -> do
matches <- mapM tryMatch (zip pp tt)
return (concat matches)
_ -> if p==t then return [] else Nothing
notMeta e = case e of
Meta _ -> False
Fun f ts -> all notMeta ts
_ -> True
-- | Converts a pattern to tree.
patt2tree :: Patt -> Tree
patt2tree (PApp f ps) = Fun f (map patt2tree ps)
patt2tree (PLit l) = Lit l
patt2tree (PVar x) = Var x
patt2tree PWild = Meta 0

532
src/runtime/haskell/PGF/Parse.hs
View File

@@ -1,532 +0,0 @@
{-# LANGUAGE BangPatterns, RankNTypes, FlexibleContexts #-}
module PGF.Parse
( ParseState
, ErrorState
, initState
, nextState
, getCompletions
, recoveryStates
, ParseInput(..), simpleParseInput, mkParseInput
, ParseOutput(..), getParseOutput
, parse
, parseWithRecovery
, getContinuationInfo
) where
import Data.Array.IArray
import Data.Array.Base (unsafeAt)
import Data.List (isPrefixOf, foldl', intercalate)
import Data.Maybe (fromMaybe, maybeToList)
import qualified Data.Map as Map
import qualified PGF.TrieMap as TrieMap
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Set as Set
import Control.Monad
import PGF.CId
import PGF.Data
import PGF.Expr(Tree)
import PGF.Macros
import PGF.TypeCheck
import PGF.Forest(Forest(Forest), linearizeWithBrackets, getAbsTrees)
-- | The input to the parser is a pair of predicates. The first one
-- 'piToken' selects a token from a list of suggestions from the grammar,
-- actually appears at the current position in the input string.
-- The second one 'piLiteral' recognizes whether a literal with forest id 'FId'
-- could be matched at the current position.
data ParseInput
= ParseInput
{ piToken :: forall a . Map.Map Token a -> Maybe a
, piLiteral :: FId -> Maybe (CId,Tree,[Token])
}
-- | This data type encodes the different outcomes which you could get from the parser.
data ParseOutput
= ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed.
| TypeError [(FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct.
-- The forest id ('FId') points to the bracketed string from the parser
-- where the type checking failed. More than one error is returned
-- if there are many analizes for some phrase but they all are not type correct.
| ParseOk [Tree] -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees.
-- The list should be non-empty.
| ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced
parse :: PGF -> Language -> Type -> Maybe Int -> [Token] -> (ParseOutput,BracketedString)
parse pgf lang typ dp toks = loop (initState pgf lang typ) toks
where
loop ps [] = getParseOutput ps typ dp
loop ps (t:ts) = case nextState ps (simpleParseInput t) of
Left es -> case es of
EState _ _ chart -> (ParseFailed (offset chart),snd (getParseOutput ps typ dp))
Right ps -> loop ps ts
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> Maybe Int -> [String] -> (ParseOutput,BracketedString)
parseWithRecovery pgf lang typ open_typs dp toks = accept (initState pgf lang typ) toks
where
accept ps [] = getParseOutput ps typ dp
accept ps (t:ts) =
case nextState ps (simpleParseInput t) of
Right ps -> accept ps ts
Left es -> skip (recoveryStates open_typs es) ts
skip ps_map [] = getParseOutput (fst ps_map) typ dp
skip ps_map (t:ts) =
case Map.lookup t (snd ps_map) of
Just ps -> accept ps ts
Nothing -> skip ps_map ts
-- | Creates an initial parsing state for a given language and
-- startup category.
initState :: PGF -> Language -> Type -> ParseState
initState pgf lang (DTyp _ start _) =
let items = case Map.lookup start (cnccats cnc) of
Just (CncCat s e labels) ->
do fid <- range (s,e)
funid <- fromMaybe [] (IntMap.lookup fid (linrefs cnc))
let lbl = 0
CncFun _ lins = unsafeAt (cncfuns cnc) funid
return (Active 0 0 funid (unsafeAt lins lbl) [PArg [] fid] (AK fidStart lbl))
Nothing -> []
in PState abs
cnc
(Chart emptyAC [] emptyPC (pproductions cnc) (totalCats cnc) 0)
(TrieMap.compose (Just (Set.fromList items)) Map.empty)
where
abs = abstract pgf
cnc = lookConcrComplete pgf lang
-- | This function constructs the simplest possible parser input.
-- It checks the tokens for exact matching and recognizes only @String@, @Int@ and @Float@ literals.
-- The @Int@ and @Float@ literals match only if the token passed is some number.
-- The @String@ literal always match but the length of the literal could be only one token.
simpleParseInput :: Token -> ParseInput
simpleParseInput t = ParseInput (Map.lookup t) (matchLit t)
where
matchLit t fid
| fid == fidString = Just (cidString,ELit (LStr t),[t])
| fid == fidInt = case reads t of {[(n,"")] -> Just (cidInt,ELit (LInt n),[t]);
_ -> Nothing }
| fid == fidFloat = case reads t of {[(d,"")] -> Just (cidFloat,ELit (LFlt d),[t]);
_ -> Nothing }
| fid == fidVar = Just (wildCId,EFun (mkCId t),[t])
| otherwise = Nothing
mkParseInput :: PGF -> Language
-> (forall a . b -> Map.Map Token a -> Maybe a)
-> [(CId,b -> Maybe (Tree,[Token]))]
-> (b -> ParseInput)
mkParseInput pgf lang ftok flits = \x -> ParseInput (ftok x) (flit x)
where
flit = mk flits
cnc = lookConcr pgf lang
mk [] = \x fid -> Nothing
mk ((c,flit):flits) = \x fid -> case Map.lookup c (cnccats cnc) of
Just (CncCat s e _) | inRange (s,e) fid
-> fmap (\(tree,toks) -> (c,tree,toks)) (flit x)
_ -> mk flits x fid
-- | From the current state and the next token
-- 'nextState' computes a new state, where the token
-- is consumed and the current position is shifted by one.
-- If the new token cannot be accepted then an error state
-- is returned.
nextState :: ParseState -> ParseInput -> Either ErrorState ParseState
nextState (PState abs cnc chart cnt0) input =
let (mb_agenda,map_items) = TrieMap.decompose cnt0
agenda = maybe [] Set.toList mb_agenda
cnt = fromMaybe TrieMap.empty (piToken input map_items)
(cnt1,chart1) = process flit ftok cnc agenda cnt chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
, offset =offset chart1+1
}
in if TrieMap.null cnt1
then Left (EState abs cnc chart2)
else Right (PState abs cnc chart2 cnt1)
where
flit = piLiteral input
ftok choices cnt =
case piToken input choices of
Just cnt' -> TrieMap.unionWith Set.union cnt' cnt
Nothing -> cnt
-- | If the next token is not known but only its prefix (possible empty prefix)
-- then the 'getCompletions' function can be used to calculate the possible
-- next words and the consequent states. This is used for word completions in
-- the GF interpreter.
getCompletions :: ParseState -> String -> Map.Map Token ParseState
getCompletions (PState abs cnc chart cnt0) w =
let (mb_agenda,map_items) = TrieMap.decompose cnt0
agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
(acc',chart1) = process flit ftok cnc agenda acc chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
, offset =offset chart1+1
}
in fmap (PState abs cnc chart2) acc'
where
flit _ = Nothing
ftok choices =
Map.unionWith (TrieMap.unionWith Set.union)
(Map.filterWithKey (\tok _ -> isPrefixOf w tok) choices)
recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map Token ParseState)
recoveryStates open_types (EState abs cnc chart) =
let open_fcats = concatMap type2fcats open_types
agenda = foldl (complete open_fcats) [] (actives chart)
(acc,chart1) = process flit ftok cnc agenda Map.empty chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
, offset =offset chart1+1
}
in (PState abs cnc chart (TrieMap.singleton [] (Set.fromList agenda)), fmap (PState abs cnc chart2) acc)
where
type2fcats (DTyp _ cat _) = case Map.lookup cat (cnccats cnc) of
Just (CncCat s e labels) -> range (s,e)
Nothing -> []
complete open_fcats items ac =
foldl (Set.foldr (\(Active j' ppos funid seqid args keyc) ->
(:) (Active j' (ppos+1) funid seqid args keyc)))
items
[set | fcat <- open_fcats, (set,_) <- lookupACByFCat fcat ac]
flit _ = Nothing
ftok toks = Map.unionWith (TrieMap.unionWith Set.union) toks
-- | This function extracts the list of all completed parse trees
-- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually
-- the same as the startup category.
getParseOutput :: ParseState -> Type -> Maybe Int -> (ParseOutput,BracketedString)
getParseOutput (PState abs cnc chart cnt) ty dp =
let froots | null roots = getPartialSeq (sequences cnc) (reverse (active chart1 : actives chart1)) seq
| otherwise = [([SymCat 0 lbl],[PArg [] fid]) | AK fid lbl <- roots]
f = Forest abs cnc (forest chart1) froots
bs = linearizeWithBrackets dp f
res | not (null es) = ParseOk es
| not (null errs) = TypeError errs
| otherwise = ParseIncomplete
where xs = [getAbsTrees f (PArg [] fid) (Just ty) dp | (AK fid lbl) <- roots]
es = concat [es | Right es <- xs]
errs = concat [errs | Left errs <- xs]
in (res,bs)
where
(mb_agenda,acc) = TrieMap.decompose cnt
agenda = maybe [] Set.toList mb_agenda
(acc',chart1) = process flit ftok cnc agenda (TrieMap.compose Nothing acc) chart
seq = [(j,cutAt ppos toks seqid,args,key) | (toks,set) <- TrieMap.toList acc'
, Active j ppos funid seqid args key <- Set.toList set]
flit _ = Nothing
ftok toks = TrieMap.unionWith Set.union (TrieMap.compose Nothing toks)
cutAt ppos toks seqid =
let seq = unsafeAt (sequences cnc) seqid
init = take (ppos-1) (elems seq)
tail = case unsafeAt seq (ppos-1) of
SymKS t -> drop (length toks) [SymKS t]
SymKP ts _ -> reverse (drop (length toks) (reverse ts))
sym -> []
in init ++ tail
roots = do let lbl = 0
fid <- maybeToList (lookupPC (PK fidStart lbl 0) (passive chart1))
PApply _ [PArg _ fid] <- maybe [] Set.toList (IntMap.lookup fid (forest chart1))
return (AK fid lbl)
getPartialSeq seqs actives = expand Set.empty
where
expand acc [] =
[(lin,args) | (j,lin,args,key) <- Set.toList acc, j == 0]
expand acc (item@(j,lin,args,key) : items)
| item `Set.member` acc = expand acc items
| otherwise = expand acc' items'
where
acc' = Set.insert item acc
items' = case lookupAC key (actives !! j) of
Nothing -> items
Just (set,_) -> [if j' < j
then let lin' = take ppos (elems (unsafeAt seqs seqid))
in (j',lin'++map (inc (length args')) lin,args'++args,key')
else (j',lin,args,key') | Active j' ppos funid seqid args' key' <- Set.toList set] ++ items
inc n (SymCat d r) = SymCat (n+d) r
inc n (SymVar d r) = SymVar (n+d) r
inc n (SymLit d r) = SymLit (n+d) r
inc n s = s
process flit ftok cnc [] acc chart = (acc,chart)
process flit ftok cnc (item@(Active j ppos funid seqid args key0):items) acc chart
| inRange (bounds lin) ppos =
case unsafeAt lin ppos of
SymCat d r -> let PArg hypos !fid = args !! d
key = AK fid r
items2 = case lookupPC (mkPK key k) (passive chart) of
Nothing -> items
Just id -> (Active j (ppos+1) funid seqid (updateAt d (PArg hypos id) args) key0) : items
(acc',items4) = predict flit ftok cnc
(IntMap.unionWith Set.union new_sc (forest chart))
key key k
acc items2
new_sc = foldl uu parent_sc hypos
parent_sc = case lookupAC key0 ((active chart : actives chart) !! (k-j)) of
Nothing -> IntMap.empty
Just (set,sc) -> sc
in case lookupAC key (active chart) of
Nothing -> process flit ftok cnc items4 acc' chart{active=insertAC key (Set.singleton item,new_sc) (active chart)}
Just (set,sc) | Set.member item set -> process flit ftok cnc items acc chart
| otherwise -> process flit ftok cnc items2 acc chart{active=insertAC key (Set.insert item set,IntMap.unionWith Set.union new_sc sc) (active chart)}
SymKS tok -> let !acc' = ftok_ [tok] (Active j (ppos+1) funid seqid args key0) acc
in process flit ftok cnc items acc' chart
SymNE -> process flit ftok cnc items acc chart
SymBIND -> let !acc' = ftok_ ["&+"] (Active j (ppos+1) funid seqid args key0) acc
in process flit ftok cnc items acc' chart
SymSOFT_BIND->process flit ftok cnc ((Active j (ppos+1) funid seqid args key0):items) acc chart
SymSOFT_SPACE->process flit ftok cnc ((Active j (ppos+1) funid seqid args key0):items) acc chart
SymCAPIT -> let !acc' = ftok_ ["&|"] (Active j (ppos+1) funid seqid args key0) acc
in process flit ftok cnc items acc' chart
SymALL_CAPIT->let !acc' = ftok_ ["&|"] (Active j (ppos+1) funid seqid args key0) acc
in process flit ftok cnc items acc' chart
SymKP syms vars
-> let to_tok (SymKS t) = [t]
to_tok SymBIND = ["&+"]
to_tok SymSOFT_BIND = []
to_tok SymSOFT_SPACE= []
to_tok SymCAPIT = ["&|"]
to_tok SymALL_CAPIT = ["&|"]
to_tok _ = []
!acc' = foldl (\acc syms -> ftok_ (concatMap to_tok syms) (Active j (ppos+1) funid seqid args key0) acc) acc
(syms:[syms' | (syms',_) <- vars])
in process flit ftok cnc items acc' chart
SymLit d r -> let PArg hypos fid = args !! d
key = AK fid r
!fid' = case lookupPC (mkPK key k) (passive chart) of
Nothing -> fid
Just fid -> fid
in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of
(toks:_) -> let !acc' = ftok_ toks (Active j (ppos+1) funid seqid (updateAt d (PArg hypos fid') args) key0) acc
in process flit ftok cnc items acc' chart
[] -> case flit fid of
Just (cat,lit,toks)
-> let fid' = nextId chart
!acc' = ftok_ toks (Active j (ppos+1) funid seqid (updateAt d (PArg hypos fid') args) key0) acc
in process flit ftok cnc items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart)
,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart)
,nextId =nextId chart+1
}
Nothing -> process flit ftok cnc items acc chart
SymVar d r -> let PArg hypos fid0 = args !! d
(fid1,fid2) = hypos !! r
key = AK fid1 0
!fid' = case lookupPC (mkPK key k) (passive chart) of
Nothing -> fid1
Just fid -> fid
in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of
(toks:_) -> let !acc' = ftok_ toks (Active j (ppos+1) funid seqid (updateAt d (PArg (updateAt r (fid',fid2) hypos) fid0) args) key0) acc
in process flit ftok cnc items acc' chart
[] -> case flit fid1 of
Just (cat,lit,toks)
-> let fid' = nextId chart
!acc' = ftok_ toks (Active j (ppos+1) funid seqid (updateAt d (PArg (updateAt r (fid',fid2) hypos) fid0) args) key0) acc
in process flit ftok cnc items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart)
,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart)
,nextId =nextId chart+1
}
Nothing -> process flit ftok cnc items acc chart
| otherwise =
case lookupPC (mkPK key0 j) (passive chart) of
Nothing -> let fid = nextId chart
items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of
Nothing -> items
Just (set,sc) -> Set.foldr (\(Active j' ppos funid seqid args keyc) ->
let SymCat d _ = unsafeAt (unsafeAt (sequences cnc) seqid) ppos
PArg hypos _ = args !! d
in (:) (Active j' (ppos+1) funid seqid (updateAt d (PArg hypos fid) args) keyc)) items set
in process flit ftok cnc items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart)
,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart)
,nextId =nextId chart+1
}
Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items
in process flit ftok cnc items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)}
where
!lin = unsafeAt (sequences cnc) seqid
!k = offset chart
mkPK (AK fid lbl) j = PK fid lbl j
rhs funid lbl = unsafeAt lins lbl
where
CncFun _ lins = unsafeAt (cncfuns cnc) funid
uu forest (fid1,fid2) =
case IntMap.lookup fid2 (lindefs cnc) of
Just funs -> foldl (\forest funid -> IntMap.insertWith Set.union fid2 (Set.singleton (PApply funid [PArg [] fid1])) forest) forest funs
Nothing -> forest
ftok_ [] item cnt = ftok Map.empty cnt
ftok_ (tok:toks) item cnt =
ftok (Map.singleton tok (TrieMap.singleton toks (Set.singleton item))) cnt
predict flit ftok cnc forest key0 key@(AK fid lbl) k acc items =
let (acc1,items1) = case IntMap.lookup fid forest of
Nothing -> (acc,items)
Just set -> Set.foldr foldProd (acc,items) set
(acc2,items2) = case IntMap.lookup fid (lexicon cnc) >>= IntMap.lookup lbl of
Just tmap -> let (mb_v,toks) = TrieMap.decompose (TrieMap.map (toItems key0 k) tmap)
acc1' = ftok toks acc1
items1' = maybe [] Set.toList mb_v ++ items1
in (acc1',items1')
Nothing -> (acc1,items1)
in (acc2,items2)
where
foldProd (PCoerce fid) (acc,items) = predict flit ftok cnc forest key0 (AK fid lbl) k acc items
foldProd (PApply funid args) (acc,items) = (acc,Active k 0 funid (rhs funid lbl) args key0 : items)
foldProd (PConst _ const toks) (acc,items) = (acc,items)
toItems key@(AK fid lbl) k funids =
Set.fromList [Active k 1 funid (rhs funid lbl) [] key | funid <- IntSet.toList funids]
updateAt :: Int -> a -> [a] -> [a]
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
----------------------------------------------------------------
-- Active Chart
----------------------------------------------------------------
data Active
= Active {-# UNPACK #-} !Int
{-# UNPACK #-} !DotPos
{-# UNPACK #-} !FunId
{-# UNPACK #-} !SeqId
[PArg]
{-# UNPACK #-} !ActiveKey
deriving (Eq,Show,Ord)
data ActiveKey
= AK {-# UNPACK #-} !FId
{-# UNPACK #-} !LIndex
deriving (Eq,Ord,Show)
type ActiveSet = Set.Set Active
type ActiveChart = IntMap.IntMap (IntMap.IntMap (ActiveSet, IntMap.IntMap (Set.Set Production)))
emptyAC :: ActiveChart
emptyAC = IntMap.empty
lookupAC :: ActiveKey -> ActiveChart -> Maybe (ActiveSet, IntMap.IntMap (Set.Set Production))
lookupAC (AK fid lbl) chart = IntMap.lookup fid chart >>= IntMap.lookup lbl
lookupACByFCat :: FId -> ActiveChart -> [(ActiveSet, IntMap.IntMap (Set.Set Production))]
lookupACByFCat fcat chart =
case IntMap.lookup fcat chart of
Nothing -> []
Just map -> IntMap.elems map
labelsAC :: FId -> ActiveChart -> [LIndex]
labelsAC fcat chart =
case IntMap.lookup fcat chart of
Nothing -> []
Just map -> IntMap.keys map
insertAC :: ActiveKey -> (ActiveSet, IntMap.IntMap (Set.Set Production)) -> ActiveChart -> ActiveChart
insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.singleton l set) chart
----------------------------------------------------------------
-- Passive Chart
----------------------------------------------------------------
data PassiveKey
= PK {-# UNPACK #-} !FId
{-# UNPACK #-} !LIndex
{-# UNPACK #-} !Int
deriving (Eq,Ord,Show)
type PassiveChart = Map.Map PassiveKey FId
emptyPC :: PassiveChart
emptyPC = Map.empty
lookupPC :: PassiveKey -> PassiveChart -> Maybe FId
lookupPC key chart = Map.lookup key chart
insertPC :: PassiveKey -> FId -> PassiveChart -> PassiveChart
insertPC key fcat chart = Map.insert key fcat chart
----------------------------------------------------------------
-- Parse State
----------------------------------------------------------------
-- | An abstract data type whose values represent
-- the current state in an incremental parser.
data ParseState = PState Abstr Concr Chart Continuation
data Chart
= Chart
{ active :: ActiveChart
, actives :: [ActiveChart]
, passive :: PassiveChart
, forest :: IntMap.IntMap (Set.Set Production)
, nextId :: {-# UNPACK #-} !FId
, offset :: {-# UNPACK #-} !Int
}
deriving Show
type Continuation = TrieMap.TrieMap Token ActiveSet
-- | Return the Continuation of a Parsestate with exportable types
-- Used by PGFService
getContinuationInfo :: ParseState -> Map.Map [Token] [(FunId, CId, String)]
getContinuationInfo pstate = Map.map (map f . Set.toList) contMap
where
PState _abstr concr _chart cont = pstate
contMap = Map.fromList (TrieMap.toList cont) -- always get [([], _::ActiveSet)]
f :: Active -> (FunId,CId,String)
f (Active int dotpos funid seqid pargs ak) = (funid, cid, seq)
where
CncFun cid _ = cncfuns concr ! funid
seq = showSeq dotpos (sequences concr ! seqid)
showSeq :: DotPos -> Sequence -> String
showSeq pos seq = intercalate " " $ scan (drop (pos-1) (elems seq))
where
-- Scan left-to-right, stop at first non-token
scan :: [Symbol] -> [String]
scan [] = []
scan (sym:syms) = case sym of
SymKS token -> token : scan syms
_ -> []
----------------------------------------------------------------
-- Error State
----------------------------------------------------------------
-- | An abstract data type whose values represent
-- the state in an incremental parser after an error.
data ErrorState = EState Abstr Concr Chart

125
src/runtime/haskell/PGF/Printer.hs
View File

@@ -1,125 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where
import PGF.CId
import PGF.Data
import PGF.ByteCode
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import Data.List
import Data.Array.IArray
--import Data.Array.Unboxed
import Text.PrettyPrint
ppPGF :: PGF -> Doc
ppPGF pgf = ppAbs (absname pgf) (abstract pgf) $$ ppAll ppCnc (concretes pgf)
ppAbs :: Language -> Abstr -> Doc
ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
nest 2 (ppAll ppFlag (aflags a) $$
ppAll ppCat (cats a) $$
ppAll ppFun (funs a)) $$
char '}'
ppFlag :: CId -> Literal -> Doc
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';'
ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc
ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
ppFun :: CId -> (Type,Int,Maybe ([Equation],[[Instr]]),Double) -> Doc
ppFun f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
(if null eqs
then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]) $$
ppCode 0 code
ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc
ppCnc name cnc =
text "concrete" <+> ppCId name <+> char '{' $$
nest 2 (ppAll ppFlag (cflags cnc) $$
text "productions" $$
nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$
text "lindefs" $$
nest 2 (vcat (concatMap ppLinDefs (IntMap.toList (lindefs cnc)))) $$
text "linrefs" $$
nest 2 (vcat (concatMap ppLinRefs (IntMap.toList (linrefs cnc)))) $$
text "lin" $$
nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
text "sequences" $$
nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$
text "categories" $$
nest 2 (vcat (map ppCncCat (Map.toList (cnccats cnc)))) $$
text "printnames" $$
nest 2 (vcat (map ppPrintName (Map.toList (printnames cnc))))) $$
char '}'
ppCncArg :: PArg -> Doc
ppCncArg (PArg hyps fid)
| null hyps = ppFId fid
| otherwise = hsep (map (ppFId . snd) hyps) <+> text "->" <+> ppFId fid
ppProduction (fid,PApply funid args) =
ppFId fid <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppCncArg args)))
ppProduction (fid,PCoerce arg) =
ppFId fid <+> text "->" <+> char '_' <> brackets (ppFId arg)
ppProduction (fid,PConst _ _ ss) =
ppFId fid <+> text "->" <+> ppStrs ss
ppCncFun (funid,CncFun fun arr) =
ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
ppLinDefs (fid,funids) =
[ppFId fid <+> text "->" <+> ppFunId funid <> brackets (ppFId fidVar) | funid <- funids]
ppLinRefs (fid,funids) =
[ppFId fidVar <+> text "->" <+> ppFunId funid <> brackets (ppFId fid) | funid <- funids]
ppSeq :: (SeqId,Sequence) -> Doc
ppSeq (seqid,seq) =
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
ppCncCat (id,(CncCat start end labels)) =
ppCId id <+> text ":=" <+> (text "range " <+> brackets (ppFId start <+> text ".." <+> ppFId end) $$
text "labels" <+> brackets (vcat (map (text . show) (elems labels))))
ppPrintName (id,name) =
ppCId id <+> text ":=" <+> ppStrs [name]
ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
ppSymbol (SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
ppSymbol (SymKS t) = doubleQuotes (text t)
ppSymbol SymNE = text "nonExist"
ppSymbol SymBIND = text "BIND"
ppSymbol SymSOFT_BIND = text "SOFT_BIND"
ppSymbol SymSOFT_SPACE= text "SOFT_SPACE"
ppSymbol SymCAPIT = text "CAPIT"
ppSymbol SymALL_CAPIT = text "ALL_CAPIT"
ppSymbol (SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
ppStrs ss = doubleQuotes (hsep (map text ss))
ppFId fid
| fid == fidString = text "CString"
| fid == fidInt = text "CInt"
| fid == fidFloat = text "CFloat"
| fid == fidVar = text "CVar"
| fid == fidStart = text "CStart"
| otherwise = char 'C' <> int fid
ppFunId funid = char 'F' <> int funid
ppSeqId seqid = char 'S' <> int seqid
-- Utilities
ppAll :: (a -> b -> Doc) -> Map.Map a b -> Doc
ppAll p m = vcat [ p k v | (k,v) <- Map.toList m]

283
src/runtime/haskell/PGF/Probabilistic.hs
View File

@@ -1,283 +0,0 @@
module PGF.Probabilistic
( Probabilities(..)
, mkProbabilities -- :: PGF -> M.Map CId Double -> Probabilities
, defaultProbabilities -- :: PGF -> Probabilities
, getProbabilities
, setProbabilities
, showProbabilities -- :: Probabilities -> String
, readProbabilitiesFromFile -- :: FilePath -> PGF -> IO Probabilities
, probTree
, rankTreesByProbs
, mkProbDefs
) where
import PGF.CId
import PGF.Data
import PGF.Macros
import qualified Data.Map as Map
import Data.List (sortBy,partition,nub,mapAccumL)
import Data.Maybe (fromMaybe) --, fromJust
-- | An abstract data structure which represents
-- the probabilities for the different functions in a grammar.
data Probabilities = Probs {
funProbs :: Map.Map CId Double,
catProbs :: Map.Map CId (Double, [(Double, CId)])
}
-- | Renders the probability structure as string
showProbabilities :: Probabilities -> String
showProbabilities = unlines . concatMap prProb . Map.toList . catProbs where
prProb (c,(p,fns)) = pr (p,c) : map pr fns
pr (p,f) = showCId f ++ "\t" ++ show p
-- | Reads the probabilities from a file.
-- This should be a text file where on every line
-- there is a function name followed by a real number.
-- The number represents the probability mass allocated for that function.
-- The function name and the probability should be separated by a whitespace.
readProbabilitiesFromFile :: FilePath -> PGF -> IO Probabilities
readProbabilitiesFromFile file pgf = do
s <- readFile file
let ps0 = Map.fromList [(mkCId f,read p) | f:p:_ <- map words (lines s)]
return $ mkProbabilities pgf ps0
-- | Builds probability tables. The second argument is a map
-- which contains the know probabilities. If some function is
-- not in the map then it gets assigned some probability based
-- on the even distribution of the unallocated probability mass
-- for the result category.
mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
mkProbabilities pgf probs =
let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns]
cats1 = Map.mapWithKey (\c (_,fns,_) ->
let p' = fromMaybe 0 (Map.lookup c probs)
fns' = sortBy cmpProb (fill fns)
in (p', fns'))
(cats (abstract pgf))
in Probs funs1 cats1
where
cmpProb (p1,_) (p2,_) = compare p2 p1
fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs]
where
pad :: [(Maybe Double,a)] -> [(Double,a)]
pad pfs = [(fromMaybe deflt mb_p,f) | (mb_p,f) <- pfs]
where
deflt = case length [f | (Nothing,f) <- pfs] of
0 -> 0
n -> max 0 ((1 - sum [d | (Just d,f) <- pfs]) / fromIntegral n)
-- | Returns the default even distibution.
defaultProbabilities :: PGF -> Probabilities
defaultProbabilities pgf = mkProbabilities pgf Map.empty
getProbabilities :: PGF -> Probabilities
getProbabilities pgf = Probs {
funProbs = Map.map (\(_,_,_,p) -> p ) (funs (abstract pgf)),
catProbs = Map.map (\(_,fns,p) -> (p,fns)) (cats (abstract pgf))
}
setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities probs pgf = pgf {
abstract = (abstract pgf) {
funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df, p)) (funs (abstract pgf)) (funProbs probs),
cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
Map.mapWithKey (\k v -> maybe v (f v) (Map.lookup k map2)) map1
-- | compute the probability of a given tree
probTree :: PGF -> Expr -> Double
probTree pgf t = case t of
EApp f e -> probTree pgf f * probTree pgf e
EFun f -> case Map.lookup f (funs (abstract pgf)) of
Just (_,_,_,p) -> p
Nothing -> 1
_ -> 1
-- | rank from highest to lowest probability
rankTreesByProbs :: PGF -> [Expr] -> [(Expr,Double)]
rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, probTree pgf t) | t <- ts]
mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])])
mkProbDefs pgf =
let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)),
not (elem c [cidString,cidInt,cidFloat]),
let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty))
hyps0
[1..]
fns = [(f,ty) | (_,f) <- fs,
let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))]
]
((_,css),eqss) = mapAccumL (\(ngen,css) (c,hyps,fns) ->
let st0 = (1,Map.empty)
((_,eqs_map),cs) = computeConstrs pgf st0 [(fn,[],es) | (fn,(DTyp _ _ es)) <- fns]
(ngen', eqs) = mapAccumL (mkEquation eqs_map hyps) ngen fns
ceqs = [(id,DTyp [] cidFloat [],reverse eqs) | (id,eqs) <- Map.toList eqs_map, not (null eqs)]
in ((ngen',cs:css),(p_f c, mkType c hyps, eqs):ceqs)) (1,[]) cs
in (reverse (concat css),concat eqss)
where
mkEImplArg bt e
| bt == Explicit = e
| otherwise = EImplArg e
mkPImplArg bt p
| bt == Explicit = p
| otherwise = PImplArg p
mkType c hyps =
DTyp (hyps++[mkHypo (DTyp [] c es)]) cidFloat []
where
is = reverse [0..length hyps-1]
es = [mkEImplArg bt (EVar i) | (i,(bt,_,_)) <- zip is hyps]
sig = (funs (abstract pgf), \_ -> Nothing)
mkEquation ceqs hyps ngen (fn,ty@(DTyp args _ es)) =
let fs1 = case Map.lookup (p_f fn) ceqs of
Nothing -> [mkApp (k_f fn) (map (\(i,_) -> EVar (k-i-1)) vs1)]
Just eqs | null eqs -> []
| otherwise -> [mkApp (p_f fn) (map (\(i,_) -> EVar (k-i-1)) vs1)]
(ngen',fs2) = mapAccumL mkFactor2 ngen vs2
fs3 = map mkFactor3 vs3
eq = Equ (map mkTildeP xes++[PApp fn (zipWith mkArgP [1..] args)])
(mkMult (fs1++fs2++fs3))
in (ngen',eq)
where
xes = map (normalForm sig k env) es
mkTildeP e =
case e of
EImplArg e -> PImplArg (PTilde e)
e -> PTilde e
mkArgP n (bt,_,_) = mkPImplArg bt (PVar (mkCId ('v':show n)))
mkMult [] = ELit (LFlt 1)
mkMult [e] = e
mkMult es = mkApp (mkCId "mult") es
mkFactor2 ngen (src,dst) =
let vs = [EVar (k-i-1) | (i,ty) <- src]
in (ngen+1,mkApp (p_i ngen) vs)
mkFactor3 (i,DTyp _ c es) =
let v = EVar (k-i-1)
in mkApp (p_f c) (map (normalForm sig k env) es++[v])
(k,env,vs1,vs2,vs3) = mkDeps ty
mkDeps (DTyp args _ es) =
let (k,env,dep1) = updateArgs 0 [] [] args
dep2 = foldl (update k env) dep1 es
(vs2,vs3) = closure k dep2 [] []
vs1 = concat [src | (src,dst) <- dep2, elem k dst]
in (k,map (\k -> VGen k []) env,vs1,reverse vs2,vs3)
where
updateArgs k env dep [] = (k,env,dep)
updateArgs k env dep ((_,x,ty@(DTyp _ _ es)) : args) =
let dep1 = foldl (update k env) dep es ++ [([(k,ty)],[])]
env1 | x == wildCId = env
| otherwise = k : env
in updateArgs (k+1) env1 dep1 args
update k env dep e =
case e of
EApp e1 e2 -> update k env (update k env dep e1) e2
EFun _ -> dep
EVar i -> let (dep1,(src,dst):dep2) = splitAt (env !! i) dep
in dep1++(src,k:dst):dep2
closure k [] vs2 vs3 = (vs2,vs3)
closure k ((src,dst):deps) vs2 vs3
| null dst = closure k deps vs2 (vs3++src)
| otherwise =
let (deps1,deps2) = partition (\(src',dst') -> not (null [v1 | v1 <- dst, v2 <- dst', v1 == v2])) deps
deps3 = (src,dst):deps1
src2 = concatMap fst deps3
dst2 = [v | v <- concatMap snd deps3
, lookup v src2 == Nothing]
dep2 = (src2,dst2)
dst' = nub dst
in if null deps1
then if dst' == [k]
then closure k deps2 vs2 vs3
else closure k deps2 ((src,dst') : vs2) vs3
else closure k (dep2 : deps2) vs2 vs3
{-
mkNewSig src =
DTyp (mkArgs 0 0 [] src) cidFloat []
where
mkArgs k l env [] = []
mkArgs k l env ((i,DTyp _ c es) : src)
| i == k = let ty = DTyp [] c (map (normalForm sig k env) es)
in (Explicit,wildCId,ty) : mkArgs (k+1) (l+1) (VGen l [] : env) src
| otherwise = mkArgs (k+1) l (VMeta 0 env [] : env) src
-}
type CState = (Int,Map.Map CId [Equation])
computeConstrs :: PGF -> CState -> [(CId,[Patt],[Expr])] -> (CState,[[CId]])
computeConstrs pgf (ngen,eqs_map) fns@((id,pts,[]):rest)
| null rest =
let eqs_map' =
Map.insertWith (++) (p_f id)
(if null pts
then []
else [Equ pts (ELit (LFlt 1.0))])
eqs_map
in ((ngen,eqs_map'),[])
| otherwise =
let (st,ks) = mapAccumL mk_k (ngen,eqs_map) fns
mk_k (ngen,eqs_map) (id,pts,[])
| null pts = ((ngen,eqs_map),k_f id)
| otherwise = let eqs_map' =
Map.insertWith (++)
(p_f id)
[Equ pts (EFun (k_i ngen))]
eqs_map
in ((ngen+1,eqs_map'),k_i ngen)
in (st,[ks])
computeConstrs pgf st fns =
let (st',res) = mapAccumL (\st (p,fns) -> computeConstrs pgf st fns)
st
(computeConstr fns)
in (st',concat res)
where
computeConstr fns = merge (split fns (Map.empty,[]))
merge (cns,vrs) =
[(p,fns++[(id,ps++[p],es) | (id,ps,es) <- vrs])
| (p,fns) <- concatMap addArgs (Map.toList cns)]
++
if null vrs
then []
else [(PWild,[(id,ps++[PWild],es) | (id,ps,es) <- vrs])]
where
addArgs (cn,fns) = addArg (length args) cn [] fns
where
Just (DTyp args _ _es,_,_,_) = Map.lookup cn (funs (abstract pgf))
addArg 0 cn ps fns = [(PApp cn (reverse ps),fns)]
addArg n cn ps fns = concat [addArg (n-1) cn (arg:ps) fns' | (arg,fns') <- computeConstr fns]
split [] (cns,vrs) = (cns,vrs)
split ((id, ps, e:es):fns) (cns,vrs) = split fns (extract e [])
where
extract (EFun cn) args = (Map.insertWith (++) cn [(id,ps,args++es)] cns, vrs)
extract (EVar i) args = (cns, (id,ps,es):vrs)
extract (EApp e1 e2) args = extract e1 (e2:args)
extract (ETyped e ty) args = extract e args
extract (EImplArg e) args = extract e args
p_f c = mkCId ("p_"++showCId c)
p_i i = mkCId ("p_"++show i)
k_f f = mkCId ("k_"++showCId f)
k_i i = mkCId ("k_"++show i)

77
src/runtime/haskell/PGF/SortTop.hs
View File

@@ -1,77 +0,0 @@
module PGF.SortTop
( forExample
) where
import PGF.CId
import PGF.Data
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe
arguments :: Type -> [CId]
arguments (DTyp [] _ _) = []
arguments (DTyp hypos _ _) = [ t | (_,_, DTyp _ t _) <- hypos]
-- topological order of functions
-- in the order that they should be tested and generated in an example-based system
showInOrder :: Abstr -> Set.Set CId -> Set.Set CId -> Set.Set CId -> IO [[((CId,CId),[CId])]]
showInOrder abs fset remset avset =
let mtypes = typesInterm abs fset
nextsetWithArgs = Set.map (\(x,y) -> ((x, returnCat abs x), fromJust y)) $ Set.filter (isJust.snd) $ Set.map (\x -> (x, isArg abs mtypes avset x)) remset
nextset = Set.map (fst.fst) nextsetWithArgs
nextcat = Set.map (returnCat abs) nextset
diffset = Set.difference remset nextset
in
if Set.null diffset then do
return [Set.toList nextsetWithArgs]
else if Set.null nextset then do
putStrLn $ "not comparable : " ++ show diffset
return []
else do
rest <- showInOrder abs (Set.union fset nextset) (Set.difference remset nextset) (Set.union avset nextcat)
return $ (Set.toList nextsetWithArgs) : rest
isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
isArg abs mtypes scid cid =
let p = Map.lookup cid $ funs abs
(ty,_,_,_) = fromJust p
args = arguments ty
setargs = Set.fromList args
cond = Set.null $ Set.difference setargs scid
in
if isNothing p then error $ "not found " ++ show cid ++ "here !!"
else if cond then return args
else Nothing
typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
typesInterm abs fset =
let fs = funs abs
fsetTypes = Set.map (\x ->
let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs
in (x,c)) fset
in Map.fromList $ Set.toList fsetTypes
{-
takeArgs :: Map.Map CId CId -> Map.Map CId Expr -> CId -> Expr
takeArgs mtypes mexpr ty =
let xarg = head $ Map.keys $ Map.filter (==ty) mtypes
in fromJust $ Map.lookup xarg mexpr
doesReturnCat :: Type -> CId -> Bool
doesReturnCat (DTyp _ c _) cat = c == cat
-}
returnCat :: Abstr -> CId -> CId
returnCat abs cid =
let p = Map.lookup cid $ funs abs
(DTyp _ c _,_,_,_) = fromJust p
in if isNothing p then error $ "not found "++ show cid ++ " in abstract "
else c
-- topological order of the categories
forExample :: PGF -> IO [[((CId,CId),[CId])]]
forExample pgf = let abs = abstract pgf
in showInOrder abs Set.empty (Set.fromList $ Map.keys $ funs abs) Set.empty

72
src/runtime/haskell/PGF/Tree.hs
View File

@@ -1,72 +0,0 @@
module PGF.Tree
( Tree(..),
tree2expr, expr2tree,
prTree
) where
import PGF.CId
import PGF.Expr hiding (Tree)
--import Data.Char
import Data.List as List
--import Control.Monad
--import qualified Text.PrettyPrint as PP
--import qualified Text.ParserCombinators.ReadP as RP
-- | The tree is an evaluated expression in the abstract syntax
-- of the grammar. The type is especially restricted to not
-- allow unapplied lambda abstractions. The tree is used directly
-- from the linearizer and is produced directly from the parser.
data Tree =
Abs [(BindType,CId)] Tree -- ^ lambda abstraction. The list of variables is non-empty
| Var CId -- ^ variable
| Fun CId [Tree] -- ^ function application
| Lit Literal -- ^ literal
| Meta {-# UNPACK #-} !MetaId -- ^ meta variable
deriving (Eq, Ord)
-----------------------------------------------------
-- Conversion Expr <-> Tree
-----------------------------------------------------
-- | Converts a tree to expression. The conversion
-- is always total, every tree is a valid expression.
tree2expr :: Tree -> Expr
tree2expr = tree2expr []
where
tree2expr ys (Fun x ts) = foldl EApp (EFun x) (List.map (tree2expr ys) ts)
tree2expr ys (Lit l) = ELit l
tree2expr ys (Meta n) = EMeta n
tree2expr ys (Abs xs t) = foldr (\(b,x) e -> EAbs b x e) (tree2expr (List.map snd (reverse xs)++ys) t) xs
tree2expr ys (Var x) = case List.lookup x (zip ys [0..]) of
Just i -> EVar i
Nothing -> error "unknown variable"
-- | Converts an expression to tree. The conversion is only partial.
-- Variables and meta variables of function type and beta redexes are not allowed.
expr2tree :: Expr -> Tree
expr2tree e = abs [] [] e
where
abs ys xs (EAbs b x e) = abs ys ((b,x):xs) e
abs ys xs (ETyped e _) = abs ys xs e
abs ys xs e = case xs of
[] -> app ys [] e
xs -> Abs (reverse xs) (app (map snd xs++ys) [] e)
app xs as (EApp e1 e2) = app xs ((abs xs [] e2) : as) e1
app xs as (ELit l)
| List.null as = Lit l
| otherwise = error "literal of function type encountered"
app xs as (EMeta n)
| List.null as = Meta n
| otherwise = error "meta variables of function type are not allowed in trees"
app xs as (EAbs _ x e) = error "beta redexes are not allowed in trees"
app xs as (EVar i) = if length xs > i then Var (xs !! i) else Meta i
---- AR 14/12/2010: work-around needed in PGF.Paraphrase.fromDef
app xs as (EFun f) = Fun f as
app xs as (ETyped e _) = app xs as e
prTree :: Tree -> String
prTree = showExpr [] . tree2expr

99
src/runtime/haskell/PGF/TrieMap.hs
View File

@@ -1,99 +0,0 @@
module PGF.TrieMap
( TrieMap
, empty
, singleton
, lookup
, null
, compose
, decompose
, insertWith
, union, unionWith
, unions, unionsWith
, elems
, toList
, fromList, fromListWith
, map
, mapWithKey
) where
import Prelude hiding (lookup, null, map)
import qualified Data.Map as Map
import Data.List (foldl')
data TrieMap k v = Tr (Maybe v) (Map.Map k (TrieMap k v))
empty = Tr Nothing Map.empty
singleton :: [k] -> a -> TrieMap k a
singleton [] v = Tr (Just v) Map.empty
singleton (k:ks) v = Tr Nothing (Map.singleton k (singleton ks v))
lookup :: Ord k => [k] -> TrieMap k a -> Maybe a
lookup [] (Tr mb_v m) = mb_v
lookup (k:ks) (Tr mb_v m) = Map.lookup k m >>= lookup ks
null :: TrieMap k v -> Bool
null (Tr Nothing m) = Map.null m
null _ = False
compose :: Maybe v -> Map.Map k (TrieMap k v) -> TrieMap k v
compose mb_v m = Tr mb_v m
decompose :: TrieMap k v -> (Maybe v, Map.Map k (TrieMap k v))
decompose (Tr mb_v m) = (mb_v,m)
insertWith :: Ord k => (v -> v -> v) -> [k] -> v -> TrieMap k v -> TrieMap k v
insertWith f [] v0 (Tr mb_v m) = case mb_v of
Just v -> Tr (Just (f v0 v)) m
Nothing -> Tr (Just v0 ) m
insertWith f (k:ks) v0 (Tr mb_v m) = case Map.lookup k m of
Nothing -> Tr mb_v (Map.insert k (singleton ks v0) m)
Just tr -> Tr mb_v (Map.insert k (insertWith f ks v0 tr) m)
union :: Ord k => TrieMap k v -> TrieMap k v -> TrieMap k v
union = unionWith (\a b -> a)
unionWith :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v
unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) =
let mb_v = case (mb_v1,mb_v2) of
(Nothing,Nothing) -> Nothing
(Just v ,Nothing) -> Just v
(Nothing,Just v ) -> Just v
(Just v1,Just v2) -> Just (f v1 v2)
m = Map.unionWith (unionWith f) m1 m2
in Tr mb_v m
unions :: Ord k => [TrieMap k v] -> TrieMap k v
unions = foldl union empty
unionsWith :: Ord k => (v -> v -> v) -> [TrieMap k v] -> TrieMap k v
unionsWith f = foldl (unionWith f) empty
elems :: TrieMap k v -> [v]
elems tr = collect tr []
where
collect (Tr mb_v m) xs = maybe id (:) mb_v (Map.foldr collect xs m)
toList :: TrieMap k v -> [([k],v)]
toList tr = collect [] tr []
where
collect ks (Tr mb_v m) xs = maybe id (\v -> (:) (ks,v)) mb_v (Map.foldrWithKey (\k -> collect (k:ks)) xs m)
fromListWith :: Ord k => (v -> v -> v) -> [([k],v)] -> TrieMap k v
fromListWith f xs = foldl' (\trie (ks,v) -> insertWith f ks v trie) empty xs
fromList :: Ord k => [([k],v)] -> TrieMap k v
fromList xs = fromListWith const xs
map :: (a -> b) -> TrieMap k a -> TrieMap k b
map f (Tr mb_v m) = Tr (fmap f mb_v) (Map.map (map f) m)
mapWithKey :: ([k] -> a -> b) -> TrieMap k a -> TrieMap k b
mapWithKey f (Tr mb_v m) = Tr (fmap (f []) mb_v) (Map.mapWithKey (\k -> mapWithKey (f . (k:))) m)

105
src/runtime/haskell/PGF/Type.hs
View File

@@ -1,105 +0,0 @@
module PGF.Type ( Type(..), Hypo, CId,
readType, showType,
mkType, mkHypo, mkDepHypo, mkImplHypo,
unType,
pType, ppType, ppHypo ) where
import PGF.CId
import {-# SOURCE #-} PGF.Expr
import Data.Char
import Data.List
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
--import Control.Monad
-- | To read a type from a 'String', use 'readType'.
data Type =
DTyp [Hypo] CId [Expr]
deriving (Eq,Ord,Show)
-- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis
type Hypo = (BindType,CId,Type)
-- | Reads a 'Type' from a 'String'.
readType :: String -> Maybe Type
readType s = case [x | (x,cs) <- RP.readP_to_S pType s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders type as 'String'. The list
-- of identifiers is the list of all free variables
-- in the expression in order reverse to the order
-- of binding.
showType :: [CId] -> Type -> String
showType vars = PP.render . ppType 0 vars
-- | creates a type from list of hypothesises, category and
-- list of arguments for the category. The operation
-- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create
-- @h_1 -> ... -> h_n -> C e_1 ... e_m@
mkType :: [Hypo] -> CId -> [Expr] -> Type
mkType hyps cat args = DTyp hyps cat args
-- | creates hypothesis for non-dependent type i.e. A
mkHypo :: Type -> Hypo
mkHypo ty = (Explicit,wildCId,ty)
-- | creates hypothesis for dependent type i.e. (x : A)
mkDepHypo :: CId -> Type -> Hypo
mkDepHypo x ty = (Explicit,x,ty)
-- | creates hypothesis for dependent type with implicit argument i.e. ({x} : A)
mkImplHypo :: CId -> Type -> Hypo
mkImplHypo x ty = (Implicit,x,ty)
unType :: Type -> ([Hypo], CId, [Expr])
unType (DTyp hyps cat es) = (hyps, cat, es)
pType :: RP.ReadP Type
pType = do
RP.skipSpaces
hyps <- RP.sepBy (pHypo >>= \h -> RP.skipSpaces >> RP.string "->" >> return h) RP.skipSpaces
RP.skipSpaces
(cat,args) <- pAtom
return (DTyp (concat hyps) cat args)
where
pHypo =
do (cat,args) <- pAtom
return [(Explicit,wildCId,DTyp [] cat args)]
RP.<++
do RP.between (RP.char '(') (RP.char ')') pHypoBinds
pHypoBinds = do
xs <- RP.option [(Explicit,wildCId)] $ do
xs <- pBinds
RP.skipSpaces
RP.char ':'
return xs
ty <- pType
return [(b,v,ty) | (b,v) <- xs]
pAtom = do
cat <- pCId
RP.skipSpaces
args <- RP.sepBy pArg RP.skipSpaces
return (cat, args)
ppType :: Int -> [CId] -> Type -> PP.Doc
ppType d scope (DTyp hyps cat args)
| null hyps = ppRes scope cat args
| otherwise = let (scope',hdocs) = mapAccumL (ppHypo 1) scope hyps
in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope' cat args) hdocs)
where
ppRes scope cat es
| null es = ppCId cat
| otherwise = ppParens (d > 3) (ppCId cat PP.<+> PP.hsep (map (ppExpr 4 scope) es))
ppHypo :: Int -> [CId] -> (BindType,CId,Type) -> ([CId],PP.Doc)
ppHypo d scope (Explicit,x,typ) = if x == wildCId
then (scope,ppType d scope typ)
else let y = freshName x scope
in (y:scope,PP.parens (ppCId y PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
ppHypo d scope (Implicit,x,typ) = if x == wildCId
then (scope,PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
else let y = freshName x scope
in (y:scope,PP.parens (PP.braces (ppCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))

677
src/runtime/haskell/PGF/TypeCheck.hs
View File

@@ -1,677 +0,0 @@
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RankNTypes #-}
----------------------------------------------------------------------
-- |
-- Module : PGF.TypeCheck
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-- Type checking in abstract syntax with dependent types.
-- The type checker also performs renaming and checking for unknown
-- functions. The variable references are replaced by de Bruijn indices.
--
-----------------------------------------------------------------------------
module PGF.TypeCheck ( checkType, checkExpr, inferExpr
, ppTcError, TcError(..)
-- internals needed for the typechecking of forests
, MetaStore, emptyMetaStore, newMeta, newGuardedMeta
, getMeta, setMeta, lookupMeta, MetaValue(..)
, Scope, emptyScope, scopeSize, scopeEnv, addScopedVar
, TcM(..), runTcM, TType(..), Selector(..)
, tcExpr, infExpr, eqType, eqValue
, lookupFunType, typeGenerators, eval
, generateForMetas, generateForForest, checkResolvedMetaStore
) where
import PGF.Data
import PGF.Expr hiding (eval, apply, applyValue, value2expr)
import qualified PGF.Expr as Expr
import PGF.Macros (cidInt, cidFloat, cidString) -- typeOfHypo
import PGF.CId
import Data.Map as Map
import Data.IntMap as IntMap
import Data.Maybe as Maybe
import Data.List as List
import Control.Applicative
import Control.Monad
--import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Error
import Text.PrettyPrint
-----------------------------------------------------
-- The Scope
-----------------------------------------------------
data TType = TTyp Env Type
newtype Scope = Scope [(CId,TType)]
emptyScope = Scope []
addScopedVar :: CId -> TType -> Scope -> Scope
addScopedVar x tty (Scope gamma) = Scope ((x,tty):gamma)
-- | returns the type and the De Bruijn index of a local variable
lookupVar :: CId -> Scope -> Maybe (Int,TType)
lookupVar x (Scope gamma) = listToMaybe [(i,tty) | ((y,tty),i) <- zip gamma [0..], x == y]
-- | returns the type and the name of a local variable
getVar :: Int -> Scope -> (CId,TType)
getVar i (Scope gamma) = gamma !! i
scopeEnv :: Scope -> Env
scopeEnv (Scope gamma) = let n = length gamma
in [VGen (n-i-1) [] | i <- [0..n-1]]
scopeVars :: Scope -> [CId]
scopeVars (Scope gamma) = List.map fst gamma
scopeSize :: Scope -> Int
scopeSize (Scope gamma) = length gamma
-----------------------------------------------------
-- The Monad
-----------------------------------------------------
type MetaStore s = IntMap (MetaValue s)
data MetaValue s
= MUnbound s Scope TType [Expr -> TcM s ()]
| MBound Expr
| MGuarded Expr [Expr -> TcM s ()] {-# UNPACK #-} !Int -- the Int is the number of constraints that have to be solved
-- to unlock this meta variable
newtype TcM s a = TcM {unTcM :: forall b . Abstr -> (a -> MetaStore s -> s -> b -> b)
-> (TcError -> s -> b -> b)
-> (MetaStore s -> s -> b -> b)}
class Selector s where
splitSelector :: s -> (s,s)
select :: CId -> Scope -> Maybe Int -> TcM s (Expr,TType)
instance Applicative (TcM s) where
pure = return
(<*>) = ap
instance Monad (TcM s) where
return x = TcM (\abstr k h -> k x)
f >>= g = TcM (\abstr k h -> unTcM f abstr (\x -> unTcM (g x) abstr k h) h)
instance Selector s => Alternative (TcM s) where
empty = mzero
(<|>) = mplus
instance Selector s => MonadPlus (TcM s) where
mzero = TcM (\abstr k h ms s -> id)
mplus f g = TcM (\abstr k h ms s -> let (s1,s2) = splitSelector s
in unTcM f abstr k h ms s1 . unTcM g abstr k h ms s2)
instance MonadState s (TcM s) where
get = TcM (\abstr k h ms s -> k s ms s)
put s = TcM (\abstr k h ms _ -> k () ms s)
instance MonadError TcError (TcM s) where
throwError e = TcM (\abstr k h ms -> h e)
catchError f fh = TcM (\abstr k h ms -> unTcM f abstr k (\e s -> unTcM (fh e) abstr k h ms s) ms)
instance Functor (TcM s) where
fmap f m = TcM (\abstr k h -> unTcM m abstr (k . f) h)
runTcM :: Abstr -> TcM s a -> MetaStore s -> s -> ([(s,TcError)],[(MetaStore s,s,a)])
runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b
in (es,(ms,s,x) : xs))
(\e s cp b -> let (es,xs) = cp b
in ((s,e) : es,xs))
ms s id ([],[])
lookupCatHyps :: CId -> TcM s [Hypo]
lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
Just (hyps,_,_) -> k hyps ms
Nothing -> h (UnknownCat cat))
lookupFunType :: CId -> TcM s Type
lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of
Just (ty,_,_,_) -> k ty ms
Nothing -> h (UnknownFun fun))
typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)]
typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
where
x = return
[(0.25,EVar i,tty) | (i,(_,tty@(TTyp _ (DTyp _ cat' _)))) <- zip [0..] gamma
, cat == cat']
where
Scope gamma = scope
y | cat == cidInt = return [(1.0,ELit (LInt 999), TTyp [] (DTyp [] cat []))]
| cat == cidFloat = return [(1.0,ELit (LFlt 3.14), TTyp [] (DTyp [] cat []))]
| cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))]
| otherwise = TcM (\abstr k h ms ->
case Map.lookup cat (cats abstr) of
Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms
Nothing -> h (UnknownCat cat))
helper (p,fn) = do
ty <- lookupFunType fn
return (p,EFun fn,TTyp [] ty)
normalize gens = [(p/s,e,tty) | (p,e,tty) <- gens]
where
s = sum [p | (p,_,_) <- gens]
emptyMetaStore :: MetaStore s
emptyMetaStore = IntMap.empty
newMeta :: Scope -> TType -> TcM s MetaId
newMeta scope tty = TcM (\abstr k h ms s -> let metaid = IntMap.size ms + 1
in k metaid (IntMap.insert metaid (MUnbound s scope tty []) ms) s)
newGuardedMeta :: Expr -> TcM s MetaId
newGuardedMeta e = TcM (\abstr k h ms s -> let metaid = IntMap.size ms + 1
in k metaid (IntMap.insert metaid (MGuarded e [] 0) ms) s)
getMeta :: MetaId -> TcM s (MetaValue s)
getMeta i = TcM (\abstr k h ms -> case IntMap.lookup i ms of
Just mv -> k mv ms)
setMeta :: MetaId -> MetaValue s -> TcM s ()
setMeta i mv = TcM (\abstr k h ms -> k () (IntMap.insert i mv ms))
lookupMeta ms i =
case IntMap.lookup i ms of
Just (MBound t) -> Just t
Just (MGuarded t _ x) | x == 0 -> Just t
| otherwise -> Nothing
Just (MUnbound _ _ _ _) -> Nothing
Nothing -> Nothing
addConstraint :: MetaId -> MetaId -> (Expr -> TcM s ()) -> TcM s ()
addConstraint i j c = do
mv <- getMeta j
case mv of
MUnbound s scope tty cs -> addRef >> setMeta j (MUnbound s scope tty ((\e -> release >> c e) : cs))
MBound e -> c e
MGuarded e cs x | x == 0 -> c e
| otherwise -> addRef >> setMeta j (MGuarded e ((\e -> release >> c e) : cs) x)
where
addRef = TcM (\abstr k h ms -> case IntMap.lookup i ms of
Just (MGuarded e cs x) -> k () $! IntMap.insert i (MGuarded e cs (x+1)) ms)
release = TcM (\abstr k h ms -> case IntMap.lookup i ms of
Just (MGuarded e cs x) -> if x == 1
then unTcM (sequence_ [c e | c <- cs]) abstr k h $! IntMap.insert i (MGuarded e [] 0) ms
else k () $! IntMap.insert i (MGuarded e cs (x-1)) ms)
-----------------------------------------------------
-- Type errors
-----------------------------------------------------
-- | If an error occurs in the typechecking phase
-- the type checker returns not a plain text error message
-- but a 'TcError' structure which describes the error.
data TcError
= UnknownCat CId -- ^ Unknown category name was found.
| UnknownFun CId -- ^ Unknown function name was found.
| WrongCatArgs [CId] Type CId Int Int -- ^ A category was applied to wrong number of arguments.
-- The first integer is the number of expected arguments and
-- the second the number of given arguments.
-- The @[CId]@ argument is the list of free variables
-- in the type. It should be used for the 'showType' function.
| TypeMismatch [CId] Expr Type Type -- ^ The expression is not of the expected type.
-- The first type is the expected type, while
-- the second is the inferred. The @[CId]@ argument is the list
-- of free variables in both the expression and the type.
-- It should be used for the 'showType' and 'showExpr' functions.
| NotFunType [CId] Expr Type -- ^ Something that is not of function type was applied to an argument.
| CannotInferType [CId] Expr -- ^ It is not possible to infer the type of an expression.
| UnresolvedMetaVars [CId] Expr [MetaId] -- ^ Some metavariables have to be instantiated in order to complete the typechecking.
| UnexpectedImplArg [CId] Expr -- ^ Implicit argument was passed where the type doesn't allow it
| UnsolvableGoal [CId] MetaId Type -- ^ There is a goal that cannot be solved
deriving Eq
-- | Renders the type checking error to a document. See 'Text.PrettyPrint'.
ppTcError :: TcError -> Doc
ppTcError (UnknownCat cat) = text "Category" <+> ppCId cat <+> text "is not in scope"
ppTcError (UnknownFun fun) = text "Function" <+> ppCId fun <+> text "is not in scope"
ppTcError (WrongCatArgs xs ty cat m n) = text "Category" <+> ppCId cat <+> text "should have" <+> int m <+> text "argument(s), but has been given" <+> int n $$
text "In the type:" <+> ppType 0 xs ty
ppTcError (TypeMismatch xs e ty1 ty2) = text "Couldn't match expected type" <+> ppType 0 xs ty1 $$
text " against inferred type" <+> ppType 0 xs ty2 $$
text "In the expression:" <+> ppExpr 0 xs e
ppTcError (NotFunType xs e ty) = text "A function type is expected for the expression" <+> ppExpr 0 xs e <+> text "instead of type" <+> ppType 0 xs ty
ppTcError (CannotInferType xs e) = text "Cannot infer the type of expression" <+> ppExpr 0 xs e
ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$
text "in the expression:" <+> ppExpr 0 xs e
ppTcError (UnexpectedImplArg xs e) = braces (ppExpr 0 xs e) <+> text "is implicit argument but not implicit argument is expected here"
ppTcError (UnsolvableGoal xs metaid ty)= text "The goal:" <+> ppMeta metaid <+> colon <+> ppType 0 xs ty $$
text "cannot be solved"
-----------------------------------------------------
-- checkType
-----------------------------------------------------
-- | Check whether a given type is consistent with the abstract
-- syntax of the grammar.
checkType :: PGF -> Type -> Either TcError Type
checkType pgf ty =
unTcM (do ty <- tcType emptyScope ty
refineType ty)
(abstract pgf)
(\ty ms s _ -> Right ty)
(\err s _ -> Left err)
emptyMetaStore () (error "checkType")
tcType :: Scope -> Type -> TcM s Type
tcType scope ty@(DTyp hyps cat es) = do
(scope,hyps) <- tcHypos scope hyps
c_hyps <- lookupCatHyps cat
let m = length es
n = length [ty | (Explicit,x,ty) <- c_hyps]
(delta,es) <- tcCatArgs scope es [] c_hyps ty n m
return (DTyp hyps cat es)
tcHypos :: Scope -> [Hypo] -> TcM s (Scope,[Hypo])
tcHypos scope [] = return (scope,[])
tcHypos scope (h:hs) = do
(scope,h ) <- tcHypo scope h
(scope,hs) <- tcHypos scope hs
return (scope,h:hs)
tcHypo :: Scope -> Hypo -> TcM s (Scope,Hypo)
tcHypo scope (b,x,ty) = do
ty <- tcType scope ty
if x == wildCId
then return (scope,(b,x,ty))
else return (addScopedVar x (TTyp (scopeEnv scope) ty) scope,(b,x,ty))
tcCatArgs scope [] delta [] ty0 n m = return (delta,[])
tcCatArgs scope (EImplArg e:es) delta ((Explicit,x,ty):hs) ty0 n m = throwError (UnexpectedImplArg (scopeVars scope) e)
tcCatArgs scope (EImplArg e:es) delta ((Implicit,x,ty):hs) ty0 n m = do
e <- tcExpr scope e (TTyp delta ty)
(delta,es) <- if x == wildCId
then tcCatArgs scope es delta hs ty0 n m
else do v <- eval (scopeEnv scope) e
tcCatArgs scope es (v:delta) hs ty0 n m
return (delta,EImplArg e:es)
tcCatArgs scope es delta ((Implicit,x,ty):hs) ty0 n m = do
i <- newMeta scope (TTyp delta ty)
(delta,es) <- if x == wildCId
then tcCatArgs scope es delta hs ty0 n m
else tcCatArgs scope es (VMeta i (scopeEnv scope) [] : delta) hs ty0 n m
return (delta,EImplArg (EMeta i) : es)
tcCatArgs scope (e:es) delta ((Explicit,x,ty):hs) ty0 n m = do
e <- tcExpr scope e (TTyp delta ty)
(delta,es) <- if x == wildCId
then tcCatArgs scope es delta hs ty0 n m
else do v <- eval (scopeEnv scope) e
tcCatArgs scope es (v:delta) hs ty0 n m
return (delta,e:es)
tcCatArgs scope _ delta _ ty0@(DTyp _ cat _) n m = do
throwError (WrongCatArgs (scopeVars scope) ty0 cat n m)
-----------------------------------------------------
-- checkExpr
-----------------------------------------------------
-- | Checks an expression against a specified type.
checkExpr :: PGF -> Expr -> Type -> Either TcError Expr
checkExpr pgf e ty =
unTcM (do e <- tcExpr emptyScope e (TTyp [] ty)
checkResolvedMetaStore emptyScope e)
(abstract pgf)
(\e ms s _ -> Right e)
(\err s _ -> Left err)
emptyMetaStore () (error "checkExpr")
tcExpr :: Scope -> Expr -> TType -> TcM s Expr
tcExpr scope e0@(EAbs Implicit x e) tty =
case tty of
TTyp delta (DTyp ((Implicit,y,ty):hs) c es) -> do e <- if y == wildCId
then tcExpr (addScopedVar x (TTyp delta ty) scope)
e (TTyp delta (DTyp hs c es))
else tcExpr (addScopedVar x (TTyp delta ty) scope)
e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es))
return (EAbs Implicit x e)
_ -> do ty <- evalType (scopeSize scope) tty
throwError (NotFunType (scopeVars scope) e0 ty)
tcExpr scope e0 (TTyp delta (DTyp ((Implicit,y,ty):hs) c es)) = do
e0 <- if y == wildCId
then tcExpr (addScopedVar wildCId (TTyp delta ty) scope)
e0 (TTyp delta (DTyp hs c es))
else tcExpr (addScopedVar wildCId (TTyp delta ty) scope)
e0 (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es))
return (EAbs Implicit wildCId e0)
tcExpr scope e0@(EAbs Explicit x e) tty =
case tty of
TTyp delta (DTyp ((Explicit,y,ty):hs) c es) -> do e <- if y == wildCId
then tcExpr (addScopedVar x (TTyp delta ty) scope)
e (TTyp delta (DTyp hs c es))
else tcExpr (addScopedVar x (TTyp delta ty) scope)
e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es))
return (EAbs Explicit x e)
_ -> do ty <- evalType (scopeSize scope) tty
throwError (NotFunType (scopeVars scope) e0 ty)
tcExpr scope (EMeta _) tty = do
i <- newMeta scope tty
return (EMeta i)
tcExpr scope e0 tty = do
(e0,tty0) <- infExpr scope e0
(e0,tty0) <- appImplArg scope e0 tty0
i <- newGuardedMeta e0
eqType scope (scopeSize scope) i tty tty0
return (EMeta i)
-----------------------------------------------------
-- inferExpr
-----------------------------------------------------
-- | Tries to infer the type of a given expression. Note that
-- even if the expression is type correct it is not always
-- possible to infer its type in the GF type system.
-- In this case the function returns the 'CannotInferType' error.
inferExpr :: PGF -> Expr -> Either TcError (Expr,Type)
inferExpr pgf e =
unTcM (do (e,tty) <- infExpr emptyScope e
e <- checkResolvedMetaStore emptyScope e
ty <- evalType 0 tty
return (e,ty))
(abstract pgf)
(\e_ty ms s _ -> Right e_ty)
(\err s _ -> Left err)
emptyMetaStore () (error "inferExpr")
infExpr :: Scope -> Expr -> TcM s (Expr,TType)
infExpr scope e0@(EApp e1 e2) = do
(e1,TTyp delta ty) <- infExpr scope e1
(e0,delta,ty) <- tcArg scope e1 e2 delta ty
return (e0,TTyp delta ty)
infExpr scope e0@(EFun x) = do
case lookupVar x scope of
Just (i,tty) -> return (EVar i,tty)
Nothing -> do ty <- lookupFunType x
return (e0,TTyp [] ty)
infExpr scope e0@(EVar i) = do
return (e0,snd (getVar i scope))
infExpr scope e0@(ELit l) = do
let cat = case l of
LStr _ -> mkCId "String"
LInt _ -> mkCId "Int"
LFlt _ -> mkCId "Float"
return (e0,TTyp [] (DTyp [] cat []))
infExpr scope (ETyped e ty) = do
ty <- tcType scope ty
e <- tcExpr scope e (TTyp (scopeEnv scope) ty)
return (ETyped e ty,TTyp (scopeEnv scope) ty)
infExpr scope (EImplArg e) = do
(e,tty) <- infExpr scope e
return (EImplArg e,tty)
infExpr scope e = throwError (CannotInferType (scopeVars scope) e)
tcArg scope e1 e2 delta ty0@(DTyp [] c es) = do
ty1 <- evalType (scopeSize scope) (TTyp delta ty0)
throwError (NotFunType (scopeVars scope) e1 ty1)
tcArg scope e1 (EImplArg e2) delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = throwError (UnexpectedImplArg (scopeVars scope) e2)
tcArg scope e1 (EImplArg e2) delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do
e2 <- tcExpr scope e2 (TTyp delta ty)
if x == wildCId
then return (EApp e1 (EImplArg e2), delta,DTyp hs c es)
else do v2 <- eval (scopeEnv scope) e2
return (EApp e1 (EImplArg e2),v2:delta,DTyp hs c es)
tcArg scope e1 e2 delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = do
e2 <- tcExpr scope e2 (TTyp delta ty)
if x == wildCId
then return (EApp e1 e2,delta,DTyp hs c es)
else do v2 <- eval (scopeEnv scope) e2
return (EApp e1 e2,v2:delta,DTyp hs c es)
tcArg scope e1 e2 delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do
i <- newMeta scope (TTyp delta ty)
if x == wildCId
then tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 delta (DTyp hs c es)
else tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 (VMeta i (scopeEnv scope) [] : delta) (DTyp hs c es)
appImplArg scope e (TTyp delta (DTyp ((Implicit,x,ty1):hypos) cat es)) = do
i <- newMeta scope (TTyp delta ty1)
let delta' = if x == wildCId
then delta
else VMeta i (scopeEnv scope) [] : delta
appImplArg scope (EApp e (EImplArg (EMeta i))) (TTyp delta' (DTyp hypos cat es))
appImplArg scope e tty = return (e,tty)
-----------------------------------------------------
-- eqType
-----------------------------------------------------
eqType :: Scope -> Int -> MetaId -> TType -> TType -> TcM s ()
eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2 ty2@(DTyp hyps2 cat2 es2))
| cat1 == cat2 = do (k,delta1,delta2) <- eqHyps k delta1 hyps1 delta2 hyps2
sequence_ [eqExpr raiseTypeMatchError (addConstraint i0) k delta1 e1 delta2 e2 | (e1,e2) <- zip es1 es2]
| otherwise = raiseTypeMatchError
where
raiseTypeMatchError = do ty1 <- evalType k tty1
ty2 <- evalType k tty2
e <- refineExpr (EMeta i0)
throwError (TypeMismatch (scopeVars scope) e ty1 ty2)
eqHyps :: Int -> Env -> [Hypo] -> Env -> [Hypo] -> TcM s (Int,Env,Env)
eqHyps k delta1 [] delta2 [] =
return (k,delta1,delta2)
eqHyps k delta1 ((_,x,ty1) : h1s) delta2 ((_,y,ty2) : h2s) = do
eqType scope k i0 (TTyp delta1 ty1) (TTyp delta2 ty2)
if x == wildCId && y == wildCId
then eqHyps k delta1 h1s delta2 h2s
else if x /= wildCId && y /= wildCId
then eqHyps (k+1) ((VGen k []):delta1) h1s ((VGen k []):delta2) h2s
else raiseTypeMatchError
eqHyps k delta1 h1s delta2 h2s = raiseTypeMatchError
eqExpr :: (forall a . TcM s a) -> (MetaId -> (Expr -> TcM s ()) -> TcM s ()) -> Int -> Env -> Expr -> Env -> Expr -> TcM s ()
eqExpr fail suspend k env1 e1 env2 e2 = do
v1 <- eval env1 e1
v2 <- eval env2 e2
eqValue fail suspend k v1 v2
eqValue :: (forall a . TcM s a) -> (MetaId -> (Expr -> TcM s ()) -> TcM s ()) -> Int -> Value -> Value -> TcM s ()
eqValue fail suspend k v1 v2 = do
v1 <- deRef v1
v2 <- deRef v2
eqValue' k v1 v2
where
deRef v@(VMeta i env vs) = do
mv <- getMeta i
case mv of
MBound e -> apply env e vs
MGuarded e _ x | x == 0 -> apply env e vs
| otherwise -> return v
MUnbound _ _ _ _ -> return v
deRef v = return v
eqValue' k (VSusp i env vs1 c) v2 = suspend i (\e -> apply env e vs1 >>= \v1 -> eqValue fail suspend k (c v1) v2)
eqValue' k v1 (VSusp i env vs2 c) = suspend i (\e -> apply env e vs2 >>= \v2 -> eqValue fail suspend k v1 (c v2))
eqValue' k (VMeta i env1 vs1) (VMeta j env2 vs2) | i == j = zipWithM_ (eqValue fail suspend k) vs1 vs2
eqValue' k (VMeta i env1 vs1) v2 = do mv <- getMeta i
case mv of
MUnbound _ scopei _ cs -> bind i scopei cs env1 vs1 v2
MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env1 e vs1 >>= \v1 -> eqValue' k v1 v2) : cs) x)
eqValue' k v1 (VMeta i env2 vs2) = do mv <- getMeta i
case mv of
MUnbound _ scopei _ cs -> bind i scopei cs env2 vs2 v1
MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env2 e vs2 >>= \v2 -> eqValue' k v1 v2) : cs) x)
eqValue' k (VApp f1 vs1) (VApp f2 vs2) | f1 == f2 = zipWithM_ (eqValue fail suspend k) vs1 vs2
eqValue' k (VConst f1 vs1) (VConst f2 vs2) | f1 == f2 = zipWithM_ (eqValue fail suspend k) vs1 vs2
eqValue' k (VLit l1) (VLit l2 ) | l1 == l2 = return ()
eqValue' k (VGen i vs1) (VGen j vs2) | i == j = zipWithM_ (eqValue fail suspend k) vs1 vs2
eqValue' k (VClosure env1 (EAbs _ x1 e1)) (VClosure env2 (EAbs _ x2 e2)) = let v = VGen k []
in eqExpr fail suspend (k+1) (v:env1) e1 (v:env2) e2
eqValue' k (VClosure env1 (EAbs _ x1 e1)) v2 = let v = VGen k []
in do v1 <- eval (v:env1) e1
v2 <- applyValue v2 [v]
eqValue fail suspend (k+1) v1 v2
eqValue' k v1 (VClosure env2 (EAbs _ x2 e2)) = let v = VGen k []
in do v1 <- applyValue v1 [v]
v2 <- eval (v:env2) e2
eqValue fail suspend (k+1) v1 v2
eqValue' k v1 v2 = fail
bind i scope cs env vs0 v = do
let k = scopeSize scope
vs = reverse (List.take k env) ++ vs0
xs = nub [i | VGen i [] <- vs]
if length vs /= length xs
then suspend i (\e -> apply env e vs0 >>= \iv -> eqValue fail suspend k iv v)
else do v <- occurCheck i k xs v
e0 <- value2expr (length xs) v
let e = addLam vs0 e0
setMeta i (MBound e)
sequence_ [c e | c <- cs]
where
addLam [] e = e
addLam (v:vs) e = EAbs Explicit var (addLam vs e)
var = mkCId "v"
occurCheck i0 k xs (VApp f vs) = do vs <- mapM (occurCheck i0 k xs) vs
return (VApp f vs)
occurCheck i0 k xs (VLit l) = return (VLit l)
occurCheck i0 k xs (VMeta i env vs) = do if i == i0
then fail
else return ()
mv <- getMeta i
case mv of
MBound e -> apply env e vs >>= occurCheck i0 k xs
MGuarded e _ _ -> apply env e vs >>= occurCheck i0 k xs
MUnbound _ scopei _ _ | scopeSize scopei > k -> fail
| otherwise -> do vs <- mapM (occurCheck i0 k xs) vs
return (VMeta i env vs)
occurCheck i0 k xs (VSusp i env vs cnt) = do suspend i (\e -> apply env e vs >>= \v -> occurCheck i0 k xs (cnt v) >> return ())
return (VSusp i env vs cnt)
occurCheck i0 k xs (VGen i vs) = case List.findIndex (==i) xs of
Just i -> do vs <- mapM (occurCheck i0 k xs) vs
return (VGen i vs)
Nothing -> fail
occurCheck i0 k xs (VConst f vs) = do vs <- mapM (occurCheck i0 k xs) vs
return (VConst f vs)
occurCheck i0 k xs (VClosure env e) = do env <- mapM (occurCheck i0 k xs) env
return (VClosure env e)
occurCheck i0 k xs (VImplArg e) = do e <- occurCheck i0 k xs e
return (VImplArg e)
-----------------------------------------------------------
-- three ways of dealing with meta variables that
-- still have to be resolved
-----------------------------------------------------------
checkResolvedMetaStore :: Scope -> Expr -> TcM s Expr
checkResolvedMetaStore scope e = do
e <- refineExpr e
TcM (\abstr k h ms ->
let xs = [i | (i,mv) <- IntMap.toList ms, not (isResolved mv)]
in if List.null xs
then k () ms
else h (UnresolvedMetaVars (scopeVars scope) e xs))
return e
where
isResolved (MUnbound _ _ _ []) = True
isResolved (MGuarded _ _ _) = True
isResolved (MBound _) = True
isResolved _ = False
generateForMetas :: Selector s => (Scope -> TType -> TcM s Expr) -> Expr -> TcM s Expr
generateForMetas prove e = do
(e,_) <- infExpr emptyScope e
fillinVariables
refineExpr e
where
fillinVariables = do
fvs <- TcM (\abstr k h ms -> k [(i,s,scope,tty,cs) | (i,MUnbound s scope tty cs) <- IntMap.toList ms] ms)
case fvs of
[] -> return ()
(i,_,scope,tty,cs):_ -> do e <- prove scope tty
setMeta i (MBound e)
sequence_ [c e | c <- cs]
fillinVariables
generateForForest :: (Scope -> TType -> TcM FId Expr) -> Expr -> TcM FId Expr
generateForForest prove e = do
-- fillinVariables
refineExpr e
{-
where
fillinVariables = do
fvs <- TcM (\abstr k h ms -> k [(i,s,scope,tty,cs) | (i,MUnbound s scope tty cs) <- IntMap.toList ms] ms)
case fvs of
[] -> return ()
(i,s,scope,tty,cs):_ -> TcM (\abstr k h ms s0 ->
case snd $ runTcM abstr (prove scope tty) ms s of
[] -> unTcM (do ty <- evalType (scopeSize scope) tty
throwError (UnsolvableGoal (scopeVars scope) s ty)
) abstr k h ms s
((ms,_,e):_) -> unTcM (do setMeta i (MBound e)
sequence_ [c e | c <- cs]
fillinVariables
) abstr k h ms s)
-}
-----------------------------------------------------
-- evalType
-----------------------------------------------------
evalType :: Int -> TType -> TcM s Type
evalType k (TTyp delta ty) = evalTy funs k delta ty
where
evalTy sig k delta (DTyp hyps cat es) = do
(k,delta,hyps) <- evalHypos sig k delta hyps
es <- mapM (\e -> eval delta e >>= value2expr k) es
return (DTyp hyps cat es)
evalHypos sig k delta [] = return (k,delta,[])
evalHypos sig k delta ((b,x,ty):hyps) = do
ty <- evalTy sig k delta ty
(k,delta,hyps) <- if x == wildCId
then evalHypos sig k delta hyps
else evalHypos sig (k+1) ((VGen k []):delta) hyps
return (k,delta,(b,x,ty) : hyps)
-----------------------------------------------------
-- refinement
-----------------------------------------------------
refineExpr :: Expr -> TcM s Expr
refineExpr e = TcM (\abstr k h ms -> k (refineExpr_ ms e) ms)
refineExpr_ ms e = refine e
where
refine (EAbs b x e) = EAbs b x (refine e)
refine (EApp e1 e2) = EApp (refine e1) (refine e2)
refine (ELit l) = ELit l
refine (EMeta i) = case IntMap.lookup i ms of
Just (MBound e ) -> refine e
Just (MGuarded e _ _) -> refine e
_ -> EMeta i
refine (EFun f) = EFun f
refine (EVar i) = EVar i
refine (ETyped e ty) = ETyped (refine e) (refineType_ ms ty)
refine (EImplArg e) = EImplArg (refine e)
refineType :: Type -> TcM s Type
refineType ty = TcM (\abstr k h ms -> k (refineType_ ms ty) ms)
refineType_ ms (DTyp hyps cat es) = DTyp [(b,x,refineType_ ms ty) | (b,x,ty) <- hyps] cat (List.map (refineExpr_ ms) es)
eval :: Env -> Expr -> TcM s Value
eval env e = TcM (\abstr k h ms -> k (Expr.eval (funs abstr,lookupMeta ms) env e) ms)
apply :: Env -> Expr -> [Value] -> TcM s Value
apply env e vs = TcM (\abstr k h ms -> k (Expr.apply (funs abstr,lookupMeta ms) env e vs) ms)
applyValue :: Value -> [Value] -> TcM s Value
applyValue v vs = TcM (\abstr k h ms -> k (Expr.applyValue (funs abstr,lookupMeta ms) v vs) ms)
value2expr :: Int -> Value -> TcM s Expr
value2expr i v = TcM (\abstr k h ms -> k (Expr.value2expr (funs abstr,lookupMeta ms) i v) ms)

20
src/runtime/haskell/PGF/Utilities.hs
View File

@@ -1,20 +0,0 @@
-- | Basic utilities
module PGF.Utilities where
import Data.Set(empty,member,insert)
-- | Like 'Data.List.nub', but O(n log n) instead of O(n^2), since it uses a set to lookup previous things.
-- The result list is stable (the elements are returned in the order they occur), and lazy.
-- Requires that the list elements can be compared by Ord.
-- Code ruthlessly taken from <http://hpaste.org/54411>
nub' :: Ord a => [a] -> [a]
nub' = loop empty
where loop _ [] = []
loop seen (x : xs)
| member x seen = loop seen xs
| otherwise = x : loop (insert x seen) xs
-- | Replace all occurences of an element by another element.
replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z)

856
src/runtime/haskell/PGF/VisualizeTree.hs
View File

@@ -1,856 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : VisualizeTree
-- Maintainer : KA
-- Stability : (stable)
-- Portability : (portable)
--
-- Print a graph of an abstract syntax tree in Graphviz DOT format
-- Based on BB's VisualizeGrammar
-----------------------------------------------------------------------------
module PGF.VisualizeTree
( GraphvizOptions(..)
, graphvizDefaults
, graphvizAbstractTree
, graphvizParseTree
, graphvizParseTreeDep
, graphvizDependencyTree
, Labels, getDepLabels
, CncLabels, getCncDepLabels
, graphvizBracketedString
, graphvizAlignment
, gizaAlignment
, conlls2latexDoc
) where
import PGF.CId (wildCId,showCId,ppCId,mkCId) --CId,pCId,
import PGF.Data
import PGF.Expr (Tree) -- showExpr
import PGF.Linearize
----import PGF.LatexVisualize (conll2latex) ---- should be separate module?
import PGF.Macros (lookValCat, BracketedString(..))
--lookMap, BracketedTokn(..), flattenBracketedString
import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
import Data.List (intersperse,nub,mapAccumL,find,groupBy,sortBy,partition)
import Data.Ord (comparing)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Text.PrettyPrint
--import Data.Array.IArray
--import Control.Monad
--import qualified Data.Set as Set
--import qualified Text.ParserCombinators.ReadP as RP
data GraphvizOptions = GraphvizOptions {noLeaves :: Bool,
noFun :: Bool,
noCat :: Bool,
noDep :: Bool,
nodeFont :: String,
leafFont :: String,
nodeColor :: String,
leafColor :: String,
nodeEdgeStyle :: String,
leafEdgeStyle :: String
}
graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
-- | Renders abstract syntax tree in Graphviz format.
-- The pair of 'Bool' @(funs,cats)@ lets you control whether function names and
-- category names are included in the rendered tree.
graphvizAbstractTree :: PGF -> (Bool,Bool) -> Tree -> String
graphvizAbstractTree pgf (funs,cats) = render . tree2graph
where
tree2graph t =
text "graph {" $$
ppGraph [] [] 0 t $$
text "}"
getAbs xs (EAbs _ x e) = getAbs (x:xs) e
getAbs xs (ETyped e _) = getAbs xs e
getAbs xs e = (xs,e)
getApp (EApp x (EImplArg y)) es = getApp x es
getApp (EApp x y) es = getApp x (y:es)
getApp (ETyped e _) es = getApp e es
getApp e es = (e,es)
getLbl scope (EFun f) = let fun = if funs then ppCId f else empty
cat = if cats then ppCId (lookValCat (abstract pgf) f) else empty
sep = if funs && cats then colon else empty
in fun <+> sep <+> cat
getLbl scope (ELit l) = text (escapeStr (render (ppLit l)))
getLbl scope (EMeta i) = ppMeta i
getLbl scope (EVar i) = ppCId (scope !! i)
getLbl scope (ETyped e _) = getLbl scope e
getLbl scope (EImplArg e) = getLbl scope e
ppGraph scope ps i e0 =
let (xs, e1) = getAbs [] e0
(e2,args) = getApp e1 []
binds = if null xs
then empty
else text "\\\\" <> hcat (punctuate comma (map ppCId xs)) <+> text "->"
(lbl,eargs) = case e2 of
EAbs _ _ _ -> (char '@', e2:args) -- eta-redexes are rendered with artificial "@" node
_ -> (getLbl scope' e2, args)
scope' = xs ++ scope
in ppNode (i:ps) <> text "[label =" <+> doubleQuotes (binds <+> lbl) <> text ", style = \"solid\", shape = \"plaintext\"] ;" $$
(if null ps
then empty
else ppNode ps <+> text "--" <+> ppNode (i:ps) <+> text "[style = \"solid\"];") $$
vcat (zipWith (ppGraph scope' (i:ps)) [0..] eargs)
ppNode ps = char 'n' <> hcat (punctuate (char '_') (map int ps))
escapeStr [] = []
escapeStr ('\\':cs) = '\\':'\\':escapeStr cs
escapeStr ('"' :cs) = '\\':'"' :escapeStr cs
escapeStr (c :cs) = c :escapeStr cs
type Labels = Map.Map CId [String]
-- | Visualize word dependency tree.
graphvizDependencyTree
:: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@
-> Bool -- ^ Include extra information (debug)
-> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels'
-> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@))
-> PGF
-> CId -- ^ The language of analysis
-> Tree
-> String -- ^ Rendered output in the specified format
graphvizDependencyTree format debug mlab mclab pgf lang t =
case format of
"latex" -> render . ppLaTeX $ conll2latex' conll
"svg" -> render . ppSVG . toSVG $ conll2latex' conll
"conll" -> printCoNLL conll
"conllu" -> printCoNLL ([["# text = " ++ linearize pgf lang t], ["# tree = " ++ showExpr [] t]] ++ conll)
"malt_tab" -> render $ vcat (map (hcat . intersperse (char '\t') . (\ws -> [ws !! 0,ws !! 1,ws !! 3,ws !! 6,ws !! 7])) wnodes)
"malt_input" -> render $ vcat (map (hcat . intersperse (char '\t') . take 6) wnodes)
_ -> render $ text "digraph {" $$
space $$
nest 2 (text "rankdir=LR ;" $$
text "node [shape = plaintext] ;" $$
vcat nodes $$
vcat links) $$
text "}"
where
conll = maybe conll0 (\ls -> fixCoNLL ls conll0) mclab
conll0 = (map.map) render wnodes
nodes = map mkNode leaves
links = map mkLink [(fid, fromMaybe (dep_lbl,nil) (lookup fid deps)) | ((cat,fid,fun,_),_,w) <- tail leaves]
-- CoNLL format: ID FORM LEMMA PLEMMA POS PPOS FEAT PFEAT HEAD PHEAD DEPREL PDEPREL
-- P variants are automatically predicted rather than gold standard
wnodes = [[int i, maltws ws, ppCId fun, ppCId (posCat cat), ppCId cat, int lind, int parent, text lab, unspec, unspec] |
((cat,fid,fun,lind),i,ws) <- tail leaves,
let (lab,parent) = fromMaybe (dep_lbl,0)
(do (lbl,fid) <- lookup fid deps
(_,i,_) <- find (\((_,fid1,_,_),i,_) -> fid == fid1) leaves
return (lbl,i))
]
maltws = text . concat . intersperse "+" . words -- no spaces in column 2
nil = -1
bss = bracketedLinearize pgf lang t
root = (wildCId,nil,wildCId,0)
leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . concatMap (getLeaves root)) bss
deps = let (_,(h,deps)) = getDeps 0 [] t []
in (h,(dep_lbl,nil)):deps
groupAndIndexIt id [] = []
groupAndIndexIt id ((p,w):pws) = (p,id,w) : groupAndIndexIt (id+1) pws
--- groupAndIndexIt id ((p,w):pws) = let (ws,pws1) = collect pws
--- in (p,id,unwords (w:ws)) : groupAndIndexIt (id+1) pws1
where
collect pws@((p1,w):pws1)
| p == p1 = let (ws,pws2) = collect pws1
in (w:ws,pws2)
collect pws = ([],pws)
getLeaves parent bs =
case bs of
Leaf w -> [(parent,w)]
Bracket cat fid _ lind fun _ bss -> concatMap (getLeaves (cat,fid,fun,lind)) bss
mkNode ((_,p,_,_),i,w) =
tag p <+> brackets (text "label = " <> doubleQuotes (int i <> char '.' <+> text w)) <+> semi
mkLink (x,(lbl,y)) = tag y <+> text "->" <+> tag x <+> text "[label = " <> doubleQuotes (text lbl) <> text "] ;"
labels = maybe Map.empty id mlab
clabels = maybe [] id mclab
posCat cat = case Map.lookup cat labels of
Just [p] -> mkCId p
_ -> cat
getDeps n_fid xs (EAbs _ x e) es = getDeps n_fid (x:xs) e es
getDeps n_fid xs (EApp e1 e2) es = getDeps n_fid xs e1 (e2:es)
getDeps n_fid xs (EImplArg e) es = getDeps n_fid xs e es
getDeps n_fid xs (ETyped e _) es = getDeps n_fid xs e es
getDeps n_fid xs (EFun f) es = let (n_fid_1,ds) = descend n_fid xs es
(mb_h, deps) = selectHead f ds
in case mb_h of
Just (fid,deps0) -> (n_fid_1+1,(fid,deps0++
[(n_fid_1,(dep_lbl,fid))]++
concat [(m,(lbl,fid)):ds | (lbl,(m,ds)) <- deps]))
Nothing -> (n_fid_1+1,(n_fid_1,concat [(m,(lbl,n_fid_1)):ds | (lbl,(m,ds)) <- deps]))
getDeps n_fid xs (EMeta i) es = (n_fid+2,(n_fid,[]))
getDeps n_fid xs (EVar i) _ = (n_fid+2,(n_fid,[]))
getDeps n_fid xs (ELit l) [] = (n_fid+1,(n_fid,[]))
descend n_fid xs es = mapAccumL (\n_fid e -> getDeps n_fid xs e []) n_fid es
selectHead f ds =
case Map.lookup f labels of
Just lbls -> extractHead (zip lbls ds)
Nothing -> extractLast ds
where
extractHead [] = (Nothing, [])
extractHead (ld@(l,d):lds)
| l == head_lbl = (Just d,lds)
| otherwise = let (mb_h,deps) = extractHead lds
in (mb_h,ld:deps)
extractLast [] = (Nothing, [])
extractLast (d:ds)
| null ds = (Just d,[])
| otherwise = let (mb_h,deps) = extractLast ds
in (mb_h,(dep_lbl,d):deps)
dep_lbl = "dep"
head_lbl = "head"
root_lbl = "ROOT"
unspec = text "_"
-- auxiliaries for UD conversion PK 15/12/2018
rmcomments :: String -> String
rmcomments [] = []
rmcomments ('-':'-':xs) = []
rmcomments ('-':x :xs) = '-':rmcomments (x:xs)
rmcomments (x:xs) = x:rmcomments xs
-- | Prepare lines obtained from a configuration file for labels for
-- use with 'graphvizDependencyTree'. Format per line /fun/ /label/@*@.
getDepLabels :: String -> Labels
-- getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map (words . rmcomments) (lines s)]
-- the old function, without dependencies
graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
graphvizParseTree = graphvizParseTreeDep Nothing
graphvizParseTreeDep :: Maybe Labels -> PGF -> Language -> GraphvizOptions -> Tree -> String
graphvizParseTreeDep mbl pgf lang opts tree = graphvizBracketedString opts mbl tree $ bracketedLinearize pgf lang tree
graphvizBracketedString :: GraphvizOptions -> Maybe Labels -> Tree -> [BracketedString] -> String
graphvizBracketedString opts mbl tree bss = render graphviz_code
where
graphviz_code
= text "graph {" $$
text node_style $$
vcat internal_nodes $$
(if noLeaves opts then empty
else text leaf_style $$
leaf_nodes
) $$ text "}"
leaf_style = mkOption "edge" "style" (leafEdgeStyle opts) ++
mkOption "edge" "color" (leafColor opts) ++
mkOption "node" "fontcolor" (leafColor opts) ++
mkOption "node" "fontname" (leafFont opts) ++
mkOption "node" "shape" "plaintext"
node_style = mkOption "edge" "style" (nodeEdgeStyle opts) ++
mkOption "edge" "color" (nodeColor opts) ++
mkOption "node" "fontcolor" (nodeColor opts) ++
mkOption "node" "fontname" (nodeFont opts) ++
mkOption "node" "shape" nodeshape
where nodeshape | noFun opts && noCat opts = "point"
| otherwise = "plaintext"
mkOption object optname optvalue
| null optvalue = ""
| otherwise = object ++ "[" ++ optname ++ "=\"" ++ optvalue ++ "\"]; "
mkNode fun cat
| noFun opts = showCId cat
| noCat opts = showCId fun
| otherwise = showCId fun ++ " : " ++ showCId cat
nil = -1
internal_nodes = [mkLevel internals |
internals <- getInternals (map ((,) nil) bss),
not (null internals)]
leaf_nodes = mkLevel [(parent, id, mkLeafNode cat word) |
(id, (parent, (cat,word))) <- zip [100000..] (concatMap (getLeaves (mkCId "?") nil) bss)]
getInternals [] = []
getInternals nodes
= nub [(parent, fid, mkNode fun cat) |
(parent, Bracket cat fid _ _ fun _ _) <- nodes]
: getInternals [(fid, child) |
(_, Bracket _ fid _ _ _ _ children) <- nodes,
child <- children]
getLeaves cat parent (Leaf word) = [(parent, (cat, word))] -- the lowest cat before the word
getLeaves _ parent (Bracket cat fid _ i _ _ children)
= concatMap (getLeaves cat fid) children
mkLevel nodes
= text "subgraph {rank=same;" $$
nest 2 (-- the following gives the name of the node and its label:
vcat [tag id <> text (mkOption "" "label" lbl) | (_, id, lbl) <- nodes] $$
-- the following is for fixing the order between the children:
(if length nodes > 1 then
text (mkOption "edge" "style" "invis") $$
hsep (intersperse (text " -- ") [tag id | (_, id, _) <- nodes]) <+> semi
else empty)
) $$
text "}" $$
-- the following is for the edges between parent and children:
vcat [tag pid <> text " -- " <> tag id <> text (depLabel node) | node@(pid, id, _) <- nodes, pid /= nil] $$
space
depLabel node@(parent,id,lbl)
| noDep opts = ";"
| otherwise = case getArg id of
Just (fun,arg) -> mkOption "" "label" (lookLabel fun arg)
_ -> ";"
getArg i = getArgumentPlace i (expr2numtree tree) Nothing
labels = maybe Map.empty id mbl
lookLabel fun arg = case Map.lookup fun labels of
Just xx | length xx > arg -> case xx !! arg of
"head" -> ""
l -> l
_ -> argLabel fun arg
argLabel fun arg = if arg==0 then "" else "dep#" ++ show arg --showCId fun ++ "#" ++ show arg
-- assuming the arg is head, if no configuration is given; always true for 1-arg funs
mkLeafNode cat word
| noDep opts = word --- || not (noCat opts) -- show POS only if intermediate nodes hidden
| otherwise = posCat cat ++ "\n" ++ word -- show POS in dependency tree
posCat cat = case Map.lookup cat labels of
Just [p] -> p
_ -> showCId cat
---- to restore the argument place from bracketed linearization
data NumTree = NumTree Int CId [NumTree]
getArgumentPlace :: Int -> NumTree -> Maybe (CId,Int) -> Maybe (CId,Int)
getArgumentPlace i tree@(NumTree int fun ts) mfi
| i == int = mfi
| otherwise = case [fj | (t,x) <- zip ts [0..], Just fj <- [getArgumentPlace i t (Just (fun,x))]] of
fj:_ -> Just fj
_ -> Nothing
expr2numtree :: Expr -> NumTree
expr2numtree = fst . renumber 0 . flatten where
flatten e = case e of
EApp f a -> case flatten f of
NumTree _ g ts -> NumTree 0 g (ts ++ [flatten a])
EFun f -> NumTree 0 f []
renumber i t@(NumTree _ f ts) = case renumbers i ts of
(ts',j) -> (NumTree j f ts', j+1)
renumbers i ts = case ts of
t:tt -> case renumber i t of
(t',j) -> case renumbers j tt of (tt',k) -> (t':tt',k)
_ -> ([],i)
----- end this terrible stuff AR 4/11/2015
type Rel = (Int,[Int])
-- possibly needs changes after clearing about many-to-many on this level
type IndexedSeq = (Int,[String])
type LangSeq = [IndexedSeq]
data PreAlign = PreAlign [LangSeq] [[Rel]]
deriving Show
-- alignment structure for a phrase in 2 languages, along with the
-- many-to-many relations
genPreAlignment :: PGF -> [Language] -> Expr -> PreAlign
genPreAlignment pgf langs = lin2align . linsBracketed
where
linsBracketed t = [bracketedLinearize pgf lang t | lang <- langs]
lin2align :: [[BracketedString]] -> PreAlign
lin2align bsss = PreAlign langSeqs langRels
where
(langSeqs,langRels) = mkLayers leaves
nil = -1
leaves = map (groupAndIndexIt 0 . concatMap (getLeaves nil)) bsss
groupAndIndexIt id [] = []
groupAndIndexIt id ((p,w):pws) = let (ws,pws1) = collect pws
in (p,id,unwords (w:ws)) : groupAndIndexIt (id+1) pws1
where
collect pws@((p1,w):pws1)
| p == p1 = let (ws,pws2) = collect pws1
in (w:ws,pws2)
collect pws = ([],pws)
getLeaves parent bs =
case bs of
Leaf w -> [(parent,w)]
Bracket _ fid _ _ _ _ bss -> concatMap (getLeaves fid) bss
mkLayers (cs:css:rest) = let (lrest, rrest) = mkLayers (css:rest)
in ((fields cs) : lrest, (map (mkLinks css) cs) : rrest)
mkLayers [cs] = ([fields cs], [])
mkLayers _ = ([],[])
mkLinks cs (p0,id0,_) = (id0,indices)
where
indices = [id1 | (p1,id1,_) <- cs, p1 == p0]
fields cs = [(id, [w]) | (_,id,w) <- cs]
-- we assume we have 2 languages - source and target
gizaAlignment :: PGF -> (Language,Language) -> Expr -> (String,String,String)
gizaAlignment pgf (l1,l2) e = let PreAlign [rl1,rl2] rels = genPreAlignment pgf [l1,l2] e
in
(unwords (map showIndSeq rl1), unwords (concat $ map snd rl2),
unwords $ words $ showRels rl2 (concat rels))
showIndSeq (_,l) = let ww = map words l
w_ = map (intersperse "_") ww
in
concat $ concat w_
showRels inds2 [] = []
showRels inds2 ((ind,is):rest) =
let lOffs = computeOffset inds2 0
ltemp = [(i,getOffsetIndex i lOffs) | i <- is]
lcurr = concat $ map (\(offset,ncomp) -> [show ind ++ "-" ++ show (-1 + offset + ii) ++ " "| ii <- [1..ncomp]]) (map snd ltemp)
lrest = showRels inds2 rest
in
(unwords lcurr) ++ lrest
getOffsetIndex i lst = let ll = filter (\(x,_) -> x == i) lst
in
snd $ head ll
computeOffset [] transp = []
computeOffset ((i,l):rest) transp = let nw = (length $ words $ concat l)
in (i,(transp,nw)) : (computeOffset rest (transp + nw))
-- alignment in the Graphviz format from the intermediate structure
-- same effect as the old direct function
graphvizAlignment :: PGF -> [Language] -> Expr -> String
graphvizAlignment pgf langs exp =
render (text "digraph {" $$
space $$
nest 2 (text "rankdir=LR ;" $$
text "node [shape = record] ;" $$
space $$
renderList 0 lrels rrels) $$
text "}")
where
(PreAlign lrels rrels) = genPreAlignment pgf langs exp
renderList ii (l:ls) (r:rs) = struct ii <> text "[label = \"" <> fields l <> text "\"] ;" $$
(case ls of
[] -> empty
_ -> vcat [struct ii <> colon <> tag id0
<> colon <> char 'e' <+> text "->" <+> struct (ii+1)
<> colon <> tag id1 <> colon <> char 'w' <+> semi
| (id0,ids) <- r, id1 <- ids] $$ renderList (ii + 1) ls rs)
renderList ii [] _ = empty
renderList ii [l] [] = struct ii <> text "[label = \"" <> fields l <> text "\"] ;"
fields cs = hsep (intersperse (char '|') [tbrackets (tag id) <> text (' ':w) | (id,ws) <- cs, w <- ws])
-- auxiliaries for graphviz syntax
struct l = text ("struct" ++ show l)
tbrackets d = char '<' <> d <> char '>'
tag i
| i < 0 = char 'r' <> int (negate i)
| otherwise = char 'n' <> int i
---------------------- should be a separate module?
-- visualization with latex output. AR Nov 2015
conlls2latexDoc :: [String] -> String
conlls2latexDoc =
render .
latexDoc .
vcat .
intersperse (text "" $+$ app "vspace" (text "4mm")) .
map conll2latex .
filter (not . null)
conll2latex :: String -> Doc
conll2latex = ppLaTeX . conll2latex' . parseCoNLL
conll2latex' :: CoNLL -> [LaTeX]
conll2latex' = dep2latex . conll2dep'
data Dep = Dep {
wordLength :: Int -> Double -- length of word at position int -- was: fixed width, millimetres (>= 20.0)
, tokens :: [(String,(String,String))] -- word, (pos,features) (0..)
, deps :: [((Int,Int),String)] -- from, to, label
, root :: Int -- root word position
}
-- some general measures
defaultWordLength = 20.0 -- the default fixed width word length, making word 100 units
defaultUnit = 0.2 -- unit in latex pictures, 0.2 millimetres
spaceLength = 10.0
charWidth = 1.8
wsize rwld w = 100 * rwld w + spaceLength -- word length, units
wpos rwld i = sum [wsize rwld j | j <- [0..i-1]] -- start position of the i'th word
wdist rwld x y = sum [wsize rwld i | i <- [min x y .. max x y - 1]] -- distance between words x and y
labelheight h = h + arcbase + 3 -- label just above arc; 25 would put it just below
labelstart c = c - 15.0 -- label starts 15u left of arc centre
arcbase = 30.0 -- arcs start and end 40u above the bottom
arcfactor r = r * 600 -- reduction of arc size from word distance
xyratio = 3 -- width/height ratio of arcs
putArc :: (Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand]
putArc frwld height x y label = [oval,arrowhead,labelling] where
oval = Put (ctr,arcbase) (OvalTop (wdth,hght))
arrowhead = Put (endp,arcbase + 5) (ArrowDown 5) -- downgoing arrow 5u above the arc base
labelling = Put (labelstart ctr,labelheight (hght/2)) (TinyText label)
dxy = wdist frwld x y -- distance between words, >>= 20.0
ndxy = 100 * rwld * fromIntegral height -- distance that is indep of word length
hdxy = dxy / 2 -- half the distance
wdth = dxy - (arcfactor rwld)/dxy -- longer arcs are wider in proportion
hght = ndxy / (xyratio * rwld) -- arc height is independent of word length
begp = min x y -- begin position of oval
ctr = wpos frwld begp + hdxy + (if x < y then 20 else 10) -- LR arcs are farther right from center of oval
endp = (if x < y then (+) else (-)) ctr (wdth/2) -- the point of the arrow
rwld = 0.5 ----
dep2latex :: Dep -> [LaTeX]
dep2latex d =
[Comment (unwords (map fst (tokens d))),
Picture defaultUnit (width,height) (
[Put (wpos rwld i,0) (Text w) | (i,w) <- zip [0..] (map fst (tokens d))] -- words
++ [Put (wpos rwld i,15) (TinyText w) | (i,(w,_)) <- zip [0..] (map snd (tokens d))] -- pos tags 15u above bottom
--- ++ [Put (wpos rwld i,-15) (TinyText w) | (i,(_,w)) <- zip [0..] (map snd (tokens d))] -- features 15u below bottom -> DON'T SHOW
++ concat [putArc rwld (aheight x y) x y label | ((x,y),label) <- deps d] -- arcs and labels
++ [Put (wpos rwld (root d) + 15,height) (ArrowDown (height-arcbase))]
++ [Put (wpos rwld (root d) + 20,height - 10) (TinyText "ROOT")]
)]
where
wld i = wordLength d i -- >= 20.0
rwld i = (wld i) / defaultWordLength -- >= 1.0
aheight x y = depth (min x y) (max x y) + 1 ---- abs (x-y)
arcs = [(min u v, max u v) | ((u,v),_) <- deps d]
depth x y = case [(u,v) | (u,v) <- arcs, (x < u && v <= y) || (x == u && v < y)] of ---- only projective arcs counted
[] -> 0
uvs -> 1 + maximum (0:[depth u v | (u,v) <- uvs])
width = {-round-} (sum [wsize rwld w | (w,_) <- zip [0..] (tokens d)]) + {-round-} spaceLength * fromIntegral ((length (tokens d)) - 1)
height = 50 + 20 * {-round-} (maximum (0:[aheight x y | ((x,y),_) <- deps d]))
type CoNLL = [[String]]
parseCoNLL :: String -> CoNLL
parseCoNLL = map words . lines
--conll2dep :: String -> Dep
--conll2dep = conll2dep' . parseCoNLL
conll2dep' :: CoNLL -> Dep
conll2dep' ls = Dep {
wordLength = wld
, tokens = toks
, deps = dps
, root = head $ [read x-1 | x:_:_:_:_:_:"0":_ <- ls] ++ [1]
}
where
wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,(pos,feat)) = toks !! i in [tok,pos {-,feat-}]]) --- feat not shown
toks = [(w,(c,m)) | _:w:_:c:_:m:_ <- ls]
dps = [((read y-1, read x-1),lab) | x:_:_:_:_:_:y:lab:_ <- ls, y /="0"]
--maxdist = maximum [abs (x-y) | ((x,y),_) <- dps]
-- * LaTeX Pictures (see https://en.wikibooks.org/wiki/LaTeX/Picture)
-- We render both LaTeX and SVG from this intermediate representation of
-- LaTeX pictures.
data LaTeX = Comment String | Picture UnitLengthMM Size [DrawingCommand]
data DrawingCommand = Put Position Object
data Object = Text String | TinyText String | OvalTop Size | ArrowDown Length
type UnitLengthMM = Double
type Size = (Double,Double)
type Position = (Double,Double)
type Length = Double
-- * latex formatting
ppLaTeX = vcat . map ppLaTeX1
where
ppLaTeX1 el =
case el of
Comment s -> comment s
Picture unit size cmds ->
app "setlength{\\unitlength}" (text (show unit ++ "mm"))
$$ hang (app "begin" (text "picture")<>text (show size)) 2
(vcat (map ppDrawingCommand cmds))
$$ app "end" (text "picture")
$$ text ""
ppDrawingCommand (Put pos obj) = put pos (ppObject obj)
ppObject obj =
case obj of
Text s -> text s
TinyText s -> small (text s)
OvalTop size -> text "\\oval" <> text (show size) <> text "[t]"
ArrowDown len -> app "vector(0,-1)" (text (show len))
put p@(_,_) = app ("put" ++ show p)
small w = text "{\\tiny" <+> w <> text "}"
comment s = text "%%" <+> text s -- line break show follow
app macro arg = text "\\" <> text macro <> text "{" <> arg <> text "}"
latexDoc :: Doc -> Doc
latexDoc body =
vcat [text "\\documentclass{article}",
text "\\usepackage[utf8]{inputenc}",
text "\\begin{document}",
body,
text "\\end{document}"]
-- * SVG (see https://www.w3.org/Graphics/SVG/IG/resources/svgprimer.html)
-- | Render LaTeX pictures as SVG
toSVG = concatMap toSVG1
where
toSVG1 el =
case el of
Comment s -> []
Picture unit size@(w,h) cmds ->
[Elem "svg" ["width".=x1,"height".=y0+5,
("viewBox",unwords (map show [0,0,x1,y0+5])),
("version","1.1"),
("xmlns","http://www.w3.org/2000/svg")]
(white_bg:concatMap draw cmds)]
where
white_bg =
Elem "rect" ["x".=0,"y".=0,"width".=x1,"height".=y0+5,
("fill","white")] []
draw (Put pos obj) = objectSVG pos obj
objectSVG pos obj =
case obj of
Text s -> [text 16 pos s]
TinyText s -> [text 10 pos s]
OvalTop size -> [ovalTop pos size]
ArrowDown len -> arrowDown pos len
text h (x,y) s =
Elem "text" ["x".=xc x,"y".=yc y-2,"font-size".=h]
[CharData s]
ovalTop (x,y) (w,h) =
Elem "path" [("d",path),("stroke","black"),("fill","none")] []
where
x1 = x-w/2
x2 = min x (x1+r)
x3 = max x (x4-r)
x4 = x+w/2
y1 = y
y2 = y+r
r = h/2
sx = show . xc
sy = show . yc
path = unwords (["M",sx x1,sy y1,"Q",sx x1,sy y2,sx x2,sy y2,
"L",sx x3,sy y2,"Q",sx x4,sy y2,sx x4,sy y1])
arrowDown (x,y) len =
[Elem "line" ["x1".=xc x,"y1".=yc y,"x2".=xc x,"y2".=y2,
("stroke","black")] [],
Elem "path" [("d",unwords arrowhead)] []]
where
x2 = xc x
y2 = yc (y-len)
arrowhead = "M":map show [x2,y2,x2-3,y2-6,x2+3,y2-6]
xc x = num x+5
yc y = y0-num y
x1 = num w+10
y0 = num h+20
num x = round (scale*x)
scale = unit*5
infix 0 .=
n.=v = (n,show v)
-- * SVG is XML
data SVG = CharData String | Elem TagName Attrs [SVG]
type TagName = String
type Attrs = [(String,String)]
ppSVG svg =
vcat [text "<?xml version=\"1.0\" standalone=\"no\"?>",
text "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"",
text "\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">",
text "",
vcat (map ppSVG1 svg)] -- It should be a single <svg> element...
where
ppSVG1 svg1 =
case svg1 of
CharData s -> text (encode s)
Elem tag attrs [] ->
text "<"<>text tag<>cat (map attr attrs) <> text "/>"
Elem tag attrs svg ->
cat [text "<"<>text tag<>cat (map attr attrs) <> text ">",
nest 2 (cat (map ppSVG1 svg)),
text "</"<>text tag<>text ">"]
attr (n,v) = text " "<>text n<>text "=\""<>text (encode v)<>text "\""
encode s = foldr encodeEntity "" s
encodeEntity = encodeEntity' (const False)
encodeEntity' esc c r =
case c of
'&' -> "&amp;"++r
'<' -> "&lt;"++r
'>' -> "&gt;"++r
_ -> c:r
----------------------------------
-- concrete syntax annotations (local) on top of conll
-- examples of annotations:
-- UseComp {"not"} PART neg head
-- UseComp {*} AUX cop head
type CncLabels = [
Either
(String, String -> Maybe (String -> String,String,String))
-- (fun, word -> (pos,label,target))
-- the pos can remain unchanged, as in the current notation in the article
(String,[String])
-- (category, morphological forms)
]
fixCoNLL :: CncLabels -> CoNLL -> CoNLL
fixCoNLL cncLabels conll = map fixc conll where
labels = [l | Left l <- cncLabels]
flabels = [r | Right r <- cncLabels]
fixc row = case row of
(i:word:fun:pos:cat:x_:"0":"dep":xs) -> (i:word:fun:pos:cat:(feat cat word x_):"0":"root":xs) --- change the root label from dep to root
(i:word:fun:pos:cat:x_:j:label:xs) -> case look (fun,word) of
Just (pos',label',"head") -> (i:word:fun:pos' pos:cat:(feat cat word x_):j :label':xs)
Just (pos',label',target) -> (i:word:fun:pos' pos:cat:(feat cat word x_): getDep j target:label':xs)
_ -> (i:word:fun:pos:cat:(feat cat word x_):j:label:xs)
_ -> row
look (fun,word) = case lookup fun labels of
Just relabel -> case relabel word of
Just row -> Just row
_ -> case lookup "*" labels of
Just starlabel -> starlabel word
_ -> Nothing
_ -> case lookup "*" labels of
Just starlabel -> starlabel word
_ -> Nothing
getDep j label = maybe j id $ lookup (label,j) [((label,j),i) | i:word:fun:pos:cat:x_:j:label:xs <- conll]
feat cat word x = case lookup cat flabels of
Just tags | all isDigit x && length tags > read x -> tags !! read x
_ -> case lookup (show word) flabels of
Just (t:_) -> t
_ -> cat ++ "-" ++ x
getCncDepLabels :: String -> CncLabels
getCncDepLabels s = wlabels ws ++ flabels fs
where
wlabels =
map Left .
map merge .
groupBy (\ (x,_) (a,_) -> x == a) .
sortBy (comparing fst) .
concatMap analyse .
filter chooseW
flabels =
map Right .
map collectTags .
map words
(fs,ws) = partition chooseF $ map uncomment $ lines s
--- choose is for compatibility with the general notation
chooseW line = notElem '(' line &&
elem '{' line
--- ignoring non-local (with "(") and abstract (without "{") rules
---- TODO: this means that "(" cannot be a token
chooseF line = take 1 line == "@" --- feature assignments have the form e.g. @N SgNom SgGen ; no spaces inside tags
uncomment line = case line of
'-':'-':_ -> ""
c:cs -> c : uncomment cs
_ -> line
analyse line = case break (=='{') line of
(beg,_:ws) -> case break (=='}') ws of
(toks,_:target) -> case (getToks beg, words target) of
(funs,[ label,j]) -> [(fun, (tok, (id, label,j))) | fun <- funs, tok <- getToks toks]
(funs,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | fun <- funs, tok <- getToks toks]
_ -> []
_ -> []
_ -> []
merge rules@((fun,_):_) = (fun, \tok ->
case lookup tok (map snd rules) of
Just new -> return new
_ -> lookup "*" (map snd rules)
)
getToks = map unquote . filter (/=",") . toks
toks s = case lex s of [(t,"")] -> [t] ; [(t,cc)] -> t:toks cc ; _ -> []
unquote s = case s of '"':cc@(_:_) | last cc == '"' -> init cc ; _ -> s
collectTags (w:ws) = (tail w,ws)
-- added init to remove the last \n. otherwise, two empty lines are in between each sentence PK 17/12/2018
printCoNLL :: CoNLL -> String
printCoNLL = init . unlines . map (concat . intersperse "\t")

0
src/runtime/haskell-bind/PGF2.hsc → src/runtime/haskell/PGF2.hsc
View File

0
src/runtime/haskell-bind/PGF2/Expr.hsc → src/runtime/haskell/PGF2/Expr.hsc
View File

0
src/runtime/haskell-bind/PGF2/FFI.hsc → src/runtime/haskell/PGF2/FFI.hsc
View File

0
src/runtime/haskell-bind/PGF2/Internal.hsc → src/runtime/haskell/PGF2/Internal.hsc
View File

0
src/runtime/haskell-bind/PGF2/Type.hsc → src/runtime/haskell/PGF2/Type.hsc
View File

0
src/runtime/haskell-bind/README → src/runtime/haskell/README
View File

0
src/runtime/haskell-bind/SG.hsc → src/runtime/haskell/SG.hsc
View File

0
src/runtime/haskell-bind/SG/FFI.hs → src/runtime/haskell/SG/FFI.hs
View File

0
src/runtime/haskell-bind/examples/pgf-shell.hs → src/runtime/haskell/examples/pgf-shell.hs
View File

70
src/runtime/haskell/pgf.cabal
View File

@@ -1,70 +0,0 @@
name: pgf
version: 3.10
cabal-version: >= 1.20
build-type: Simple
license: OtherLicense
category: Natural Language Processing
synopsis: Grammatical Framework
description: A library for interpreting the Portable Grammar Format (PGF)
homepage: http://www.grammaticalframework.org/
bug-reports: https://github.com/GrammaticalFramework/GF/issues
maintainer: Thomas Hallgren
tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2
Library
default-language: Haskell2010
build-depends: base >= 4.6 && <5,
array,
containers,
bytestring,
utf8-string,
random,
pretty,
mtl,
exceptions
other-modules:
-- not really part of GF but I have changed the original binary library
-- and we have to keep the copy for now.
Data.Binary
Data.Binary.Put
Data.Binary.Get
Data.Binary.Builder
Data.Binary.IEEE754
--ghc-options: -fwarn-unused-imports
--if impl(ghc>=7.8)
-- ghc-options: +RTS -A20M -RTS
ghc-prof-options: -fprof-auto
extensions:
exposed-modules:
PGF
PGF.Internal
PGF.Haskell
other-modules:
PGF.Data
PGF.Macros
PGF.Binary
PGF.Optimize
PGF.Printer
PGF.CId
PGF.Expr
PGF.Generate
PGF.Linearize
PGF.Morphology
PGF.Paraphrase
PGF.Parse
PGF.Probabilistic
PGF.SortTop
PGF.Tree
PGF.Type
PGF.TypeCheck
PGF.Forest
PGF.TrieMap
PGF.VisualizeTree
PGF.ByteCode
PGF.OldBinary
PGF.Utilities

0
src/runtime/haskell-bind/pgf2.cabal → src/runtime/haskell/pgf2.cabal
View File

0
src/runtime/haskell-bind/utils.c → src/runtime/haskell/utils.c
View File