restored mathematical in 1.4; forgave some lock fields in overload resolution

This commit is contained in:
aarne
2008-06-20 09:21:52 +00:00
parent a21b4b0e2e
commit b0c3dfb213
35 changed files with 712 additions and 22 deletions

View File

@@ -3,7 +3,7 @@ module Main where
import System
-- Make commands for compiling and testing resource grammars.
-- usage: runghc Make present? (lang | api | pgf | test | clean)?
-- usage: runghc Make present? (lang | api | math | pgf | test | clean)?
-- With no argument, lang and api are done, in this order.
-- See 'make' below for what is done by which command.
@@ -32,6 +32,9 @@ langsLang = langs `except` ["Ara"]
-- languages for which to compile Try
langsAPI = langsLang `except` ["Cat","Hin","Ina","Rus","Tha"]
-- languages for which to compile Mathematical
langsMath = langsLang `except` ["Bul","Cat","Hin","Ina","Rus","Tha"]
-- languages for which to run treebank test
langsTest = langsLang `except` ["Cat","Hin","Spa","Tha"]
@@ -56,6 +59,9 @@ make xx = do
ifx "api" $ do
mapM_ (gfc pres presApiPath . try) langsAPI
system $ "cp */*.gfo " ++ dir
ifx "math" $ do
mapM_ (gfc False [] . math) langsMath
system $ "cp mathematical/*.gfo ../mathematical"
ifxx "pgf" $ do
system $ "gfc -s --make --name=langs --parser=off --output-dir=" ++ dir ++ " " ++
unwords [dir ++ "/Lang" ++ la ++ ".gfo" | (_,la) <- langsPGF] ++
@@ -81,6 +87,7 @@ treeb = "rf -lines -tree -file=" ++ treebankExx ++
lang (lla,la) = lla ++ "/Lang" ++ la ++ ".gf"
try (lla,la) = "api/Try" ++ la ++ ".gf"
math (lla,la) = "mathematical/Mathematical" ++ la ++ ".gf"
except ls es = filter (flip notElem es . snd) ls
only ls es = filter (flip elem es . snd) ls

View File

@@ -0,0 +1,31 @@
--1 The Mathematics API to the Resource Grammar
-- This grammar is a collection of the different modules.
-- It differs from $Lang$ in two main ways:
-- - the combinations in Noun, Verb, Adjective, Adverb, Sentence are not included
-- - instead, Symbol and Predication are used
--
--
-- In practice, the most important difference is that only present-tense sentences
-- are included, and that symbolic expressions are recognized as NPs.
abstract Mathematical =
Noun - [ComplN2], --- to avoid ambiguity
-- Verb,
Adjective,
Adverb,
Numeral,
-- Sentence,
Question,
Relative,
Conjunction,
Phrase,
Text,
Idiom,
Structural,
Symbol,
Predication,
Lexicon
** {} ;

View File

@@ -0,0 +1,27 @@
--# -path=.:present:prelude
concrete MathematicalDan of Mathematical =
NounDan - [ComplN2], --- to avoid ambiguity
-- VerbDan,
AdjectiveDan,
AdverbDan,
NumeralDan,
-- SentenceDan,
QuestionDan,
RelativeDan,
ConjunctionDan,
PhraseDan,
TextX,
IdiomDan,
StructuralDan,
SymbolDan,
PredicationDan,
LexiconDan
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,26 @@
--# -path=.:present:prelude
concrete MathematicalEng of Mathematical =
NounEng - [ComplN2], --- to avoid ambiguity
-- VerbEng,
AdjectiveEng,
AdverbEng,
NumeralEng,
-- SentenceEng,
QuestionEng,
RelativeEng,
ConjunctionEng,
PhraseEng,
StructuralEng,
TextX,
IdiomEng,
SymbolEng,
PredicationEng,
LexiconEng
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,26 @@
--# -path=.:present:prelude
concrete MathematicalFin of Mathematical =
NounFin - [ComplN2], --- to avoid ambiguity
-- VerbFin,
AdjectiveFin,
AdverbFin,
NumeralFin,
-- SentenceFin,
QuestionFin,
RelativeFin,
ConjunctionFin,
PhraseFin,
TextX,
IdiomFin,
StructuralFin,
SymbolFin,
PredicationFin,
LexiconFin
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,26 @@
--# -path=.:present:prelude
concrete MathematicalFre of Mathematical =
NounFre - [ComplN2], --- to avoid ambiguity
-- VerbFre,
AdjectiveFre,
AdverbFre,
NumeralFre,
-- SentenceFre,
QuestionFre,
RelativeFre,
ConjunctionFre,
PhraseFre,
TextX - [Tense,TPres,TPast,TFut,TCond],
IdiomFre,
StructuralFre,
SymbolFre,
PredicationFre - [predV3], ---- gf bug
LexiconFre
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,26 @@
--# -path=.:present:prelude
concrete MathematicalGer of Mathematical =
NounGer - [ComplN2], --- to avoid ambiguity
-- VerbGer,
AdjectiveGer,
AdverbGer,
NumeralGer,
-- SentenceGer,
QuestionGer,
RelativeGer,
ConjunctionGer,
PhraseGer,
TextX - [Tense,TPres],
IdiomGer,
StructuralGer,
SymbolGer,
PredicationGer,
LexiconGer
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,26 @@
--# -path=.:present:prelude
concrete MathematicalIta of Mathematical =
NounIta - [ComplN2], --- to avoid ambiguity
-- VerbIta,
AdjectiveIta,
AdverbIta,
NumeralIta,
-- SentenceIta,
QuestionIta,
RelativeIta,
ConjunctionIta,
PhraseIta,
TextX - [Tense,TPres,TPast,TFut,TCond],
IdiomIta,
StructuralIta,
SymbolIta,
PredicationIta, -- - [predV3,predV2], --- gf bug
LexiconIta
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,27 @@
--# -path=.:present:prelude
concrete MathematicalNor of Mathematical =
NounNor - [ComplN2], --- to avoid ambiguity
-- VerbNor,
AdjectiveNor,
AdverbNor,
NumeralNor,
-- SentenceNor,
QuestionNor,
RelativeNor,
ConjunctionNor,
PhraseNor,
TextX,
IdiomNor,
StructuralNor,
SymbolNor,
PredicationNor,
LexiconNor
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,26 @@
--# -path=.:present:prelude
concrete MathematicalSpa of Mathematical =
NounSpa - [ComplN2], --- to avoid ambiguity
-- VerbSpa,
AdjectiveSpa,
AdverbSpa,
NumeralSpa,
-- SentenceSpa,
QuestionSpa,
RelativeSpa,
ConjunctionSpa,
PhraseSpa,
TextSpa - [Tense,TPres,TPast,TFut,TCond],
IdiomSpa,
StructuralSpa,
SymbolSpa,
PredicationSpa, -- - [predV3,predV2], --- gf bug
LexiconSpa
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,27 @@
--# -path=.:present:prelude
concrete MathematicalSwe of Mathematical =
NounSwe - [ComplN2], --- to avoid ambiguity
-- VerbSwe,
AdjectiveSwe,
AdverbSwe,
NumeralSwe,
-- SentenceSwe,
QuestionSwe,
RelativeSwe,
ConjunctionSwe,
PhraseSwe,
TextX,
IdiomSwe,
StructuralSwe,
SymbolSwe,
PredicationSwe,
LexiconSwe
** {
flags startcat = Phr ;
} ;

View File

@@ -0,0 +1,60 @@
--1 A Small Predication Library
--
-- (c) Aarne Ranta 2003-2006 under Gnu GPL.
--
-- This library is a derived library built on the language-independent Ground
-- API of resource grammars.
abstract Predication = Cat ** {
--2 The category of atomic sentences
-- We want to use sentences in positive and negative forms but do not care about
-- tenses.
fun
PosCl : Cl -> S ; -- positive sentence: "x intersects y"
NegCl : Cl -> S ; -- negative sentence: "x doesn't intersect y"
--2 Predication patterns.
predV : V -> NP -> Cl ; -- one-place verb: "x converges"
predV2 : V2 -> NP -> NP -> Cl ; -- two-place verb: "x intersects y"
predV3 : V3 -> NP->NP-> NP -> Cl; -- three-place verb: "x intersects y at z"
predVColl : V -> NP -> NP -> Cl ; -- collective verb: "x and y intersect"
predA : A -> NP -> Cl ; -- one-place adjective: "x is even"
predA2 : A2 -> NP -> NP -> Cl ; -- two-place adj: "x is divisible by y"
predAComp : A -> NP -> NP -> Cl; -- comparative adj: "x is greater than y"
predAColl : A -> NP -> NP -> Cl ; -- collective adj: "x and y are parallel"
predN : N -> NP -> Cl ; -- one-place noun: "x is a point"
predN2 : N2 -> NP -> NP -> Cl ; -- two-place noun: "x is a divisor of y"
predNColl : N -> NP -> NP -> Cl ; -- collective noun: "x and y are duals"
predAdv : Adv -> NP -> Cl ; -- adverb: "x is inside"
predPrep : Prep -> NP -> NP -> Cl ; -- preposition: "x is outside y"
--2 Imperatives and infinitives.
impV2 : V2 -> NP -> Phr ; -- imperative: "solve the equation E"
infV2 : V2 -> NP -> Phr ; -- infinitive: "to solve the equation E"
--2 Individual-valued function applications
appN2 : N2 -> NP -> NP ; -- one-place function: "the successor of x"
appN3 : N3 -> NP -> NP -> NP ; -- two-place function: "the distance from x to y"
appColl : N2 -> NP -> NP -> NP ; -- collective function: "the sum of x and y"
--2 Families of types
-- These are expressed by relational nouns applied to arguments.
famN2 : N2 -> NP -> CN ; -- one-place family: "divisor of x"
famN3 : N3 -> NP -> NP -> CN ; -- two-place family: "path from x to y"
famColl : N2 -> NP -> NP -> CN ; -- collective family: "path between x and y"
--2 Type constructor
-- This is similar to a family except that the argument is a type.
typN2 : N2 -> CN -> CN ; -- constructed type: "list of integers"
}

View File

@@ -0,0 +1,4 @@
concrete PredicationDan of Predication = CatDan ** PredicationI with
(Syntax = SyntaxDan),
(Lang = LangDan) ;

View File

@@ -0,0 +1,4 @@
concrete PredicationEng of Predication = CatEng ** PredicationI with
(Syntax = SyntaxEng),
(Lang = LangEng) ;

View File

@@ -0,0 +1,4 @@
concrete PredicationFin of Predication = CatFin ** PredicationI with
(Syntax = SyntaxFin),
(Lang = LangFin) ;

View File

@@ -0,0 +1,4 @@
concrete PredicationFre of Predication = CatFre ** PredicationI with
(Syntax = SyntaxFre),
(Lang = LangFre) ;

View File

@@ -0,0 +1,4 @@
concrete PredicationGer of Predication = CatGer ** PredicationI with
(Syntax = SyntaxGer),
(Lang = LangGer) ;

View File

@@ -0,0 +1,51 @@
incomplete concrete PredicationI of Predication =
Cat ** open ParamX, Lang, Syntax in {
flags optimize = all_subs ;
lin
PosCl cl = mkS cl ;
NegCl cl = mkS PNeg cl ;
--2 Predication patterns.
predV v x = PredVP x (UseV v) ; -- mkCl x v ;
predV2 v x y = mkCl x v y ;
predV3 v x y z = mkCl x v y z ;
predVColl v x y = mkCl (mkNP and_Conj x y) v ;
predA a x = mkCl x a ;
predA2 a x y = mkCl x a y ;
predAComp a x y = mkCl x a y ;
predAColl a x y = mkCl (mkNP and_Conj x y) a ;
predN n x = mkCl x (mkNP IndefArt (mkCN n)) ; --- Sg/Pl ?
predN2 n x y = mkCl x (mkNP IndefArt (ComplN2 n y)) ; --- Sg/Pl ?
predNColl n x y = mkCl (mkNP and_Conj x y) (mkNP IndefArt (mkCN n)) ;
predAdv a x = mkCl x a ;
predPrep p x y = mkCl x (mkAdv p y) ;
--2 Imperatives and infinitives.
impV2 v x = mkPhr (mkImp v x) ;
infV2 v x = mkPhr (mkUtt (mkVP v x)) ;
--2 Individual-valued function applications
appN2 n x = mkNP DefArt (mkCN n x) ;
appN3 n x y = mkNP DefArt (mkCN n x y) ;
appColl n x y = mkNP DefArt (mkCN n (mkNP and_Conj x y)) ;
--2 Families of types
-- These are expressed by relational nouns applied to arguments.
famN2 n x = ComplN2 n x ;
famN3 n x y = ComplN2 (ComplN3 n x) y ;
famColl n x y = ComplN2 n (ConjNP and_Conj (BaseNP x y)) ;
--2 Type constructor
-- This is similar to a family except that the argument is a type.
typN2 f n = ComplN2 f (DetArtPl DefArt n) ;
}

View File

@@ -0,0 +1,4 @@
concrete PredicationIta of Predication = CatIta ** PredicationI with
(Syntax = SyntaxIta),
(Lang = LangIta) ;

View File

@@ -0,0 +1,4 @@
concrete PredicationNor of Predication = CatNor ** PredicationI with
(Syntax = SyntaxNor),
(Lang = LangNor) ;

View File

@@ -0,0 +1,4 @@
concrete PredicationSpa of Predication = CatSpa ** PredicationI with
(Syntax = SyntaxSpa),
(Lang = LangSpa) ;

View File

@@ -0,0 +1,4 @@
concrete PredicationSwe of Predication = CatSwe ** PredicationI with
(Syntax = SyntaxSwe),
(Lang = LangSwe) ;

View File

@@ -0,0 +1,46 @@
--1 Symbolic expressions
-- *Note*. This module is not automatically included in the main
-- grammar [Lang Lang.html].
abstract Symbol = Cat, PredefAbs ** {
--2 Noun phrases with symbols and numbers
fun
SymbPN : Symb -> PN ; -- x
IntPN : Int -> PN ; -- 27
FloatPN : Float -> PN ; -- 3.14159
NumPN : Num -> PN ;
CNNumNP : CN -> Num -> NP ; -- level five ; level 5
CNSymbNP : Det -> CN -> [Symb] -> NP ; -- (the) (2) numbers x and y
--2 Sentence consisting of a formula
SymbS : Symb -> S ; -- A
--2 Symbols as numerals
SymbNum : Symb -> Num ; -- n
SymbOrd : Symb -> Ord ; -- n'th
--2 Symbol lists
-- A symbol list has at least two elements. The last two are separated
-- by a conjunction ("and" in English), the others by commas.
-- This produces "x, y and z", in English.
cat
Symb ;
[Symb]{2} ;
fun
MkSymb : String -> Symb ;
--2 Obsolescent
CNIntNP : CN -> Int -> NP ; -- level 53 (covered by CNNumNP)
}

View File

@@ -0,0 +1,2 @@
concrete SymbolDan of Symbol = CatDan ** SymbolScand with
(ResScand = ResDan) ;

View File

@@ -0,0 +1,37 @@
concrete SymbolEng of Symbol = CatEng ** open Prelude, ResEng in {
lin
SymbPN i = {s = \\c => i.s ; g = Neutr} ; --- c
IntPN i = {s = \\c => i.s ; g = Neutr} ; --- c
FloatPN i = {s = \\c => i.s ; g = Neutr} ; --- c
NumPN i = {s = \\c => i.s ; g = Neutr} ; --- c
CNIntNP cn i = {
s = \\c => (cn.s ! Sg ! Nom ++ i.s) ;
a = agrgP3 Sg cn.g
} ;
CNSymbNP det cn xs = {
s = \\c => det.s ++ cn.s ! det.n ! c ++ xs.s ;
a = agrgP3 det.n cn.g
} ;
CNNumNP cn i = {
s = \\c => (cn.s ! Sg ! Nom ++ i.s) ;
a = agrgP3 Sg cn.g
} ;
SymbS sy = sy ;
SymbNum sy = {s = sy.s ; n = Pl ; hasCard = True} ;
SymbOrd sy = {s = sy.s ++ "th"} ;
lincat
Symb, [Symb] = SS ;
lin
MkSymb s = s ;
BaseSymb = infixSS "and" ;
ConsSymb = infixSS "," ;
}

View File

@@ -0,0 +1,42 @@
concrete SymbolFin of Symbol = CatFin ** open Prelude, NounFin, ResFin in {
lin
SymbPN i = {s = \\c => i.s} ; --- c
IntPN i = {s = \\c => i.s} ; --- c
FloatPN i = {s = \\c => i.s} ; --- c
NumPN i = {s = \\c => i.s!Sg!Nom } ; --- c
CNIntNP cn i = {
s = \\c => cn.s ! NCase Sg (npform2case Sg c) ++ i.s ;
a = agrP3 Sg ;
isPron = False
} ;
CNSymbNP det cn xs = let detcn = NounFin.DetCN det cn in {
s = \\c => detcn.s ! c ++ xs.s ;
a = detcn.a ;
isPron = False
} ;
CNNumNP cn i = {
s = \\c => cn.s ! NCase Sg (npform2case Sg c) ++ i.s ! Sg ! Nom ;
a = agrP3 Sg ;
isPron = False
} ;
SymbS sy = sy ;
SymbNum n = {s = \\_,_ => n.s ; isNum = True ; n = Pl} ;
SymbOrd n = {s = \\_,_ => n.s ++ "."} ;
lincat
Symb, [Symb] = SS ;
lin
MkSymb s = s ;
BaseSymb = infixSS "ja" ;
ConsSymb = infixSS "," ;
}

View File

@@ -0,0 +1,2 @@
concrete SymbolFre of Symbol = CatFre ** SymbolRomance with
(ResRomance = ResFre) ;

View File

@@ -0,0 +1,43 @@
concrete SymbolGer of Symbol = CatGer ** open Prelude, ResGer in {
lin
SymbPN i = {s = \\c => i.s ; g = Neutr} ; --- c
IntPN i = {s = \\c => i.s ; g = Neutr} ; --- c
FloatPN i = {s = \\c => i.s ; g = Neutr} ; --- c
NumPN i = {s = \\c => i.s ; g = Neutr} ; --- c
CNIntNP cn i = {
s = \\c => cn.s ! Weak ! Sg ! Nom ++ i.s ;
a = agrP3 Sg ;
isPron = False
} ;
CNSymbNP det cn xs = let g = cn.g in {
s = \\c => det.s ! g ! c ++ cn.s ! adjfCase det.a c ! det.n ! c ++ xs.s ;
a = agrP3 det.n ;
isPron = False
} ;
CNNumNP cn i = {
s = \\c => artDef ! (GSg cn.g) ! c ++ cn.s ! Weak ! Sg ! Nom ++ i.s ;
a = agrP3 Sg ;
isPron = False
} ;
SymbS sy = {s = \\_ => sy.s} ;
SymbNum n = {s = n.s ; n = Pl ; isNum = True} ;
SymbOrd n = {s = \\_ => n.s ++ "."} ;
lincat
Symb, [Symb] = SS ;
lin
MkSymb s = s ;
BaseSymb = infixSS "und" ;
ConsSymb = infixSS "," ;
}

View File

@@ -0,0 +1,2 @@
concrete SymbolIta of Symbol = CatIta ** SymbolRomance with
(ResRomance = ResIta) ;

View File

@@ -0,0 +1,2 @@
concrete SymbolNor of Symbol = CatNor ** SymbolScand with
(ResScand = ResNor) ;

View File

@@ -0,0 +1,41 @@
incomplete concrete SymbolRomance of Symbol =
CatRomance ** open Prelude, CommonRomance, ResRomance in {
lin
SymbPN i = {s = i.s ; g = Masc} ;
IntPN i = {s = i.s ; g = Masc} ;
FloatPN i = {s = i.s ; g = Masc} ;
NumPN i = {s = i.s!Masc ; g = Masc} ;
CNIntNP cn i = {
s = \\c => cn.s ! Sg ++ i.s ;
a = agrP3 cn.g Sg ;
hasClit = False
} ;
CNSymbNP det cn xs = let g = cn.g in {
s = \\c => det.s ! g ! npform2case c ++ cn.s ! det.n ++ xs.s ;
a = agrP3 g det.n ;
hasClit = False
} ;
CNNumNP cn i = {
s = \\c => artDef cn.g Sg (npform2case c) ++ cn.s ! Sg ++ i.s ! Masc ;
a = agrP3 cn.g Sg ;
hasClit = False
} ;
SymbS sy = {s = \\_ => sy.s} ;
SymbNum n = {s = \\_ => n.s ; isNum = True ; n = Pl} ;
SymbOrd n = {s = \\_ => n.s ++ "."} ; ---
lincat
Symb, [Symb] = SS ;
lin
MkSymb s = s ;
BaseSymb = infixSS "et" ; ----
ConsSymb = infixSS "," ;
}

View File

@@ -0,0 +1,38 @@
incomplete concrete SymbolScand of Symbol =
CatScand ** open Prelude, ResScand, CommonScand in {
lin
SymbPN i = {s = \\c => i.s ; g = Neutr} ; --- c
IntPN i = {s = \\c => i.s ; g = Neutr} ; --- c
FloatPN i = {s = \\c => i.s ; g = Neutr} ; --- c
NumPN i = {s = \\c => i.s!neutrum ; g = Neutr} ; --- c
CNIntNP cn i = {
s = \\c => (cn.s ! Sg ! DIndef ! Nom ++ i.s) ;
a = agrP3 cn.g Sg
} ;
CNSymbNP det cn xs = let g = cn.g in {
s = \\c => det.s ! cn.isMod ! g ++ cn.s ! det.n ! det.det ! caseNP c ++ xs.s ;
a = agrP3 g det.n
} ;
CNNumNP cn i = {
s = \\c => (cn.s ! Sg ! DIndef ! Nom ++ i.s ! neutrum) ;
a = agrP3 cn.g Sg
} ;
SymbS sy = {s = \\_ => sy.s} ;
SymbNum n = {s = \\_ => n.s ; isDet = True ; n = Pl} ;
SymbOrd n = {s = n.s ++ ":te" ; isDet = True} ; ---
lincat
Symb, [Symb] = SS ;
lin
MkSymb s = s ;
BaseSymb = infixSS conjAnd ;
ConsSymb = infixSS "," ;
}

View File

@@ -0,0 +1,2 @@
concrete SymbolSpa of Symbol = CatSpa ** SymbolRomance with
(ResRomance = ResSpa) ;

View File

@@ -0,0 +1,2 @@
concrete SymbolSwe of Symbol = CatSwe ** SymbolScand with
(ResScand = ResSwe) ;

View File

@@ -653,7 +653,7 @@ inferLType gr trm = case trm of
-- type inference: Nothing, type checking: Just t
-- the latter permits matching with value type
getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type))
getOverload env@gr mt t = case appForm t of
getOverload env@gr mt ot = case appForm ot of
(f@(Q m c), ts) -> case lookupOverload gr m c of
Ok typs -> do
ttys <- mapM infer ts
@@ -666,45 +666,54 @@ getOverload env@gr mt t = case appForm t of
matchOverload f typs ttys = do
let (tts,tys) = unzip ttys
let vfs = lookupOverloadInstance tys typs
let matches = [vf | vf@((v,_),_) <- vfs, matchVal mt v]
case [vf | vf@(v,f) <- vfs, matchVal mt v] of
[(val,fun)] -> return (mkApp fun tts, val)
[] -> raise $ "no overload instance of" +++ prt f +++
"for" +++ unwords (map (prtType env) tys) +++ "among" ++++
unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++
maybe [] (("with value type" +++) . prtType env) mt
case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
([(val,fun)],_) -> return (mkApp fun tts, val)
([],[(val,fun)]) -> do
checkWarn ("ignoring lock fields in resolving" +++ prt ot)
return (mkApp fun tts, val)
([],[]) -> do
raise $ "no overload instance of" +++ prt f +++
"for" +++ unwords (map (prtType env) tys) +++ "among" ++++
unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++
maybe [] (("with value type" +++) . prtType env) mt
---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";"
---- ++++ unlines (map (show . fst) typs) ----
vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of
[(val,fun)] -> do
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
([(val,fun)],_) -> do
return (mkApp fun tts, val)
([],[(val,fun)]) -> do
checkWarn ("ignoring lock fields in resolving" +++ prt ot)
return (mkApp fun tts, val)
----- unsafely exclude irritating warning AR 24/5/2008
----- checkWarn $ "WARNING: overloading of" +++ prt f +++
----- "resolved by excluding partial applications:" ++++
----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
return (mkApp fun tts, val)
_ -> raise $ "ambiguous overloading of" +++ prt f +++
"for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++
unlines [prtType env ty | (ty,_) <- vfs']
"for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++
unlines [prtType env ty | (ty,_) <- if (null vfs1) then vfs2 else vfs2]
matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where
unlocked = case v of
RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs]
_ -> []
matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
unlocked v = case v of
RecType fs -> RecType $ filter (not . isLockLabel . fst) fs
_ -> v
---- TODO: accept subtypes
---- TODO: use a trie
lookupOverloadInstance tys typs =
[(mkFunType rest val, t) |
[((mkFunType rest val, t),isExact) |
let lt = length tys,
(ty,(val,t)) <- typs, length ty >= lt,
let (pre,rest) = splitAt lt ty,
pre == tys
let isExact = pre == tys,
isExact || map unlocked pre == map unlocked tys
]
noProds vfs = [(v,f) | (v,f) <- vfs, noProd v]
noProd ty = case ty of
Prod _ _ _ -> False
_ -> True