diff --git a/src/runtime/haskell-bind/PGF.hs b/src/runtime/haskell-bind/PGF.hs deleted file mode 100644 index 11eeefd35..000000000 --- a/src/runtime/haskell-bind/PGF.hs +++ /dev/null @@ -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" diff --git a/src/runtime/haskell-bind/PGF/Internal.hs b/src/runtime/haskell-bind/PGF/Internal.hs deleted file mode 100644 index df736e788..000000000 --- a/src/runtime/haskell-bind/PGF/Internal.hs +++ /dev/null @@ -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 - diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index c47212b11..11eeefd35 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -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 -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" diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs deleted file mode 100644 index e0e50f4be..000000000 --- a/src/runtime/haskell/PGF/Binary.hs +++ /dev/null @@ -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" diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs deleted file mode 100644 index 579d6b3bb..000000000 --- a/src/runtime/haskell/PGF/ByteCode.hs +++ /dev/null @@ -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) diff --git a/src/runtime/haskell/PGF/CId.hs b/src/runtime/haskell/PGF/CId.hs deleted file mode 100644 index ed4990300..000000000 --- a/src/runtime/haskell/PGF/CId.hs +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs deleted file mode 100644 index 8c8a98fb0..000000000 --- a/src/runtime/haskell/PGF/Data.hs +++ /dev/null @@ -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]) diff --git a/src/runtime/haskell/PGF/Editor.hs b/src/runtime/haskell/PGF/Editor.hs deleted file mode 100644 index 3f69da170..000000000 --- a/src/runtime/haskell/PGF/Editor.hs +++ /dev/null @@ -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) - diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs deleted file mode 100644 index 7bd3d88ec..000000000 --- a/src/runtime/haskell/PGF/Expr.hs +++ /dev/null @@ -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 - diff --git a/src/runtime/haskell/PGF/Expr.hs-boot b/src/runtime/haskell/PGF/Expr.hs-boot deleted file mode 100644 index 34a62a410..000000000 --- a/src/runtime/haskell/PGF/Expr.hs-boot +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs deleted file mode 100644 index ee15e2cf9..000000000 --- a/src/runtime/haskell/PGF/Forest.hs +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Generate.hs b/src/runtime/haskell/PGF/Generate.hs deleted file mode 100644 index 47cddbb36..000000000 --- a/src/runtime/haskell/PGF/Generate.hs +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Haskell.hs b/src/runtime/haskell/PGF/Haskell.hs deleted file mode 100644 index 8b99a61e1..000000000 --- a/src/runtime/haskell/PGF/Haskell.hs +++ /dev/null @@ -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) diff --git a/src/runtime/haskell/PGF/Internal.hs b/src/runtime/haskell/PGF/Internal.hs index 57c8a9fe1..df736e788 100644 --- a/src/runtime/haskell/PGF/Internal.hs +++ b/src/runtime/haskell/PGF/Internal.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs deleted file mode 100644 index e3e8d92db..000000000 --- a/src/runtime/haskell/PGF/Linearize.hs +++ /dev/null @@ -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)) diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs deleted file mode 100644 index 96f9f3535..000000000 --- a/src/runtime/haskell/PGF/Macros.hs +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs deleted file mode 100644 index 2da6da44e..000000000 --- a/src/runtime/haskell/PGF/Morphology.hs +++ /dev/null @@ -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 - diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs deleted file mode 100644 index c727589f5..000000000 --- a/src/runtime/haskell/PGF/OldBinary.hs +++ /dev/null @@ -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++")" diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs deleted file mode 100644 index 8bee81f43..000000000 --- a/src/runtime/haskell/PGF/Paraphrase.hs +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs deleted file mode 100644 index d4df937db..000000000 --- a/src/runtime/haskell/PGF/Parse.hs +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs deleted file mode 100644 index 6e394c2ba..000000000 --- a/src/runtime/haskell/PGF/Printer.hs +++ /dev/null @@ -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] diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs deleted file mode 100644 index 37db7f7ff..000000000 --- a/src/runtime/haskell/PGF/Probabilistic.hs +++ /dev/null @@ -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) diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs deleted file mode 100644 index c31b32e91..000000000 --- a/src/runtime/haskell/PGF/SortTop.hs +++ /dev/null @@ -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 diff --git a/src/runtime/haskell/PGF/Tree.hs b/src/runtime/haskell/PGF/Tree.hs deleted file mode 100644 index 96b9979f4..000000000 --- a/src/runtime/haskell/PGF/Tree.hs +++ /dev/null @@ -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 - diff --git a/src/runtime/haskell/PGF/TrieMap.hs b/src/runtime/haskell/PGF/TrieMap.hs deleted file mode 100644 index fbf6ea26e..000000000 --- a/src/runtime/haskell/PGF/TrieMap.hs +++ /dev/null @@ -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) diff --git a/src/runtime/haskell/PGF/Type.hs b/src/runtime/haskell/PGF/Type.hs deleted file mode 100644 index 1d6884a7c..000000000 --- a/src/runtime/haskell/PGF/Type.hs +++ /dev/null @@ -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)) diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs deleted file mode 100644 index 5db4ef439..000000000 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ /dev/null @@ -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) diff --git a/src/runtime/haskell/PGF/Utilities.hs b/src/runtime/haskell/PGF/Utilities.hs deleted file mode 100644 index ab1b4e2fe..000000000 --- a/src/runtime/haskell/PGF/Utilities.hs +++ /dev/null @@ -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 -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) diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs deleted file mode 100644 index e27ad080b..000000000 --- a/src/runtime/haskell/PGF/VisualizeTree.hs +++ /dev/null @@ -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 "", - text "", - text "", - vcat (map ppSVG1 svg)] -- It should be a single 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 - '&' -> "&"++r - '<' -> "<"++r - '>' -> ">"++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") - diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell/PGF2.hsc similarity index 100% rename from src/runtime/haskell-bind/PGF2.hsc rename to src/runtime/haskell/PGF2.hsc diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell/PGF2/Expr.hsc similarity index 100% rename from src/runtime/haskell-bind/PGF2/Expr.hsc rename to src/runtime/haskell/PGF2/Expr.hsc diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc similarity index 100% rename from src/runtime/haskell-bind/PGF2/FFI.hsc rename to src/runtime/haskell/PGF2/FFI.hsc diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell/PGF2/Internal.hsc similarity index 100% rename from src/runtime/haskell-bind/PGF2/Internal.hsc rename to src/runtime/haskell/PGF2/Internal.hsc diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell/PGF2/Type.hsc similarity index 100% rename from src/runtime/haskell-bind/PGF2/Type.hsc rename to src/runtime/haskell/PGF2/Type.hsc diff --git a/src/runtime/haskell-bind/README b/src/runtime/haskell/README similarity index 100% rename from src/runtime/haskell-bind/README rename to src/runtime/haskell/README diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell/SG.hsc similarity index 100% rename from src/runtime/haskell-bind/SG.hsc rename to src/runtime/haskell/SG.hsc diff --git a/src/runtime/haskell-bind/SG/FFI.hs b/src/runtime/haskell/SG/FFI.hs similarity index 100% rename from src/runtime/haskell-bind/SG/FFI.hs rename to src/runtime/haskell/SG/FFI.hs diff --git a/src/runtime/haskell-bind/examples/pgf-shell.hs b/src/runtime/haskell/examples/pgf-shell.hs similarity index 100% rename from src/runtime/haskell-bind/examples/pgf-shell.hs rename to src/runtime/haskell/examples/pgf-shell.hs diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal deleted file mode 100644 index 1d11b007f..000000000 --- a/src/runtime/haskell/pgf.cabal +++ /dev/null @@ -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 diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell/pgf2.cabal similarity index 100% rename from src/runtime/haskell-bind/pgf2.cabal rename to src/runtime/haskell/pgf2.cabal diff --git a/src/runtime/haskell-bind/utils.c b/src/runtime/haskell/utils.c similarity index 100% rename from src/runtime/haskell-bind/utils.c rename to src/runtime/haskell/utils.c