diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs index b5324f68e..1063b7903 100644 --- a/src/compiler/api/GF/Compile/Compute.hs +++ b/src/compiler/api/GF/Compile/Compute.hs @@ -361,6 +361,7 @@ evalAbsDef g@(Gl gr pds _) c q args = case splitAt' arity args of Nothing -> VPAP c q args Just (_,_) -> patternMatch g c (VConst q args) (map (\(ps,t) -> ([],ps,args,t)) eqs) + Ok (_,Nothing) -> VConst q args Bad msg -> error msg apply g (VMeta i vs0) vs = VMeta i (vs0++vs) @@ -550,9 +551,10 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 Bad msg -> error msg where Gl gr _ _ = g - match env (PV v :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args + match env (PV v :ps) eqs (arg:args) + | v == identW = match env ps eqs args + | otherwise = match ((v,arg):env) ps eqs args match env (PAs v p :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args) - match env (PW :ps) eqs (arg:args) = match env ps eqs args match env (PTilde _ :ps) eqs (arg:args) = match env ps eqs args match env (p :ps) eqs (arg:args) = match' env p ps eqs arg args diff --git a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs index 1a7cb52e5..4c25aacdb 100644 --- a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs @@ -170,8 +170,9 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) = convertPatt (PC c ps) = ConP (gId c) (map convertPatt ps) convertPatt (PP (_,c) ps) = ConP (gId c) (map convertPatt ps) - convertPatt (PV v) = VarP v - convertPatt PW = WildP + convertPatt (PV v) + | v == identW = WildP + | otherwise = VarP v convertPatt (PR lbls) = ConP (rcon' ls) (map convertPatt ps) where (ls,ps) = unzip $ sortOn fst lbls convertPatt (PString s) = Lit s diff --git a/src/compiler/api/GF/Compile/GenerateBC.hs b/src/compiler/api/GF/Compile/GenerateBC.hs index e380ac409..0ee39128d 100644 --- a/src/compiler/api/GF/Compile/GenerateBC.hs +++ b/src/compiler/api/GF/Compile/GenerateBC.hs @@ -50,8 +50,9 @@ compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1) whilePV [] vrs = compileEquations gr arity st is vrs fl bs - whilePV ((vs, PV x : ps, t):eqs) vrs = whilePV eqs (((x,i):vs,ps,t) : vrs) - whilePV ((vs, PW : ps, t):eqs) vrs = whilePV eqs (( vs,ps,t) : vrs) + whilePV ((vs, PV x : ps, t):eqs) vrs + | x == identW = whilePV eqs (( vs,ps,t) : vrs) + | otherwise = whilePV eqs (((x,i):vs,ps,t) : vrs) whilePV ((vs, PTilde _ : ps, t):eqs) vrs = whilePV eqs (( vs,ps,t) : vrs) whilePV ((vs, PImplArg p:ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs whilePV ((vs, PT _ p : ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs index 796ebe301..63641249e 100644 --- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs @@ -169,7 +169,7 @@ type2metaTerm gr d ms s r rs (RecType lbls) params = in (ms',s',r',R ass,params') type2metaTerm gr d ms s r rs (Table p q) params | count == 1 = let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs q params - in (ms',s',r+(r'-r),T (TTyped p) [(PW,t)],params') + in (ms',s',r+(r'-r),T (TTyped p) [(PV identW,t)],params') | otherwise = let pv = varX (length rs+1) (ms',s',r',t,params') = type2metaTerm gr d ms s r ((delta,(pv,p)):rs) q params delta = r'-r diff --git a/src/compiler/api/GF/Compile/GrammarToPGF.hs b/src/compiler/api/GF/Compile/GrammarToPGF.hs index e5ab011ac..225affcbf 100644 --- a/src/compiler/api/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/api/GF/Compile/GrammarToPGF.hs @@ -153,7 +153,6 @@ mkPatt scope p = A.PV x -> (x:scope,C.PVar (i2i x)) A.PAs x p -> let (scope',p') = mkPatt scope p in (x:scope',C.PAs (i2i x) p') - A.PW -> ( scope,C.PWild) A.PInt i -> ( scope,C.PLit (C.LInt (fromIntegral i))) A.PFloat f -> ( scope,C.PLit (C.LFlt f)) A.PString s -> ( scope,C.PLit (C.LStr s)) diff --git a/src/compiler/api/GF/Compile/TypeCheck.hs b/src/compiler/api/GF/Compile/TypeCheck.hs index 9c8a32fe8..af32f34cc 100644 --- a/src/compiler/api/GF/Compile/TypeCheck.hs +++ b/src/compiler/api/GF/Compile/TypeCheck.hs @@ -98,7 +98,6 @@ checkDef g q ty (ps,t) = do (scope,arg_ty) <- tcPatt scope c1 p (Just arg_ty) go scope c2 res_ty ps - -- tcPatt scope c PW Nothing = do inferSigma :: Scope -> Choice -> Term -> EvalM (Term,Sigma) inferSigma scope s t = do -- GEN1 @@ -766,17 +765,16 @@ reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg res_ty <- evalCodomain x arg_v res_ty reapply2 scope c (App fun arg) res_ty args mb_ty -tcPatt scope c PW Nothing = do - i <- newResiduation scope - return (scope,VMeta i []) -tcPatt scope c PW (Just ty0) = - return (scope,ty0) tcPatt scope c (PV x) Nothing = do i <- newResiduation scope - let ty = VMeta i [] - return ((x,ty):scope,ty) + if x == identW + then return (scope,VMeta i []) + else let ty = VMeta i [] + in return ((x,ty):scope,ty) tcPatt scope c (PV x) (Just ty) = - return ((x,ty):scope,ty) + if x == identW + then return (scope,ty) + else return ((x,ty):scope,ty) tcPatt scope c (PP q ps) mb_ty = do g@(Gl gr _ isAbstract) <- globals ty <- case (if isAbstract then lookupFunType else lookupResType) gr q of @@ -923,7 +921,8 @@ measurePatt p = return (min,max,PT t p') PAs x p -> do (min,max,p) <- measurePatt p case p of - PW -> return (0,Nothing,PV x) + PV y | y == identW + -> return (0,Nothing,PV x) _ -> return (min,max,PAs x p) PImplArg p -> do (min,max,p') <- measurePatt p return (min,max,PImplArg p') @@ -941,13 +940,16 @@ measurePatt p = -> do (min1,max1,p1) <- measurePatt p1 (min2,max2,p2) <- measurePatt p2 case (p1,p2) of - (PW, PW ) -> return (0,Nothing,PW) + (PV x, PV y ) + | x == identW && y == identW + -> return (0,Nothing,PV identW) (PString s1,PString s2) -> return (min1+min2,liftM2 (+) max1 max2,PString (s1++s2)) _ -> return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1 min2 max2 p2) PRep _ _ p -> do (minp,maxp,p) <- measurePatt p case p of - PW -> return (0,Nothing,PW) - PChar -> return (0,Nothing,PW) + PV x | x == identW + -> return (0,Nothing,PV x) + PChar -> return (0,Nothing,PV identW) _ -> return (0,Nothing,PRep minp maxp p) PChar -> return (1,Just 1,p) PChars _ -> return (1,Just 1,p) diff --git a/src/compiler/api/GF/Grammar/Binary.hs b/src/compiler/api/GF/Grammar/Binary.hs index 128b652f1..017e4e5f9 100644 --- a/src/compiler/api/GF/Grammar/Binary.hs +++ b/src/compiler/api/GF/Grammar/Binary.hs @@ -224,7 +224,6 @@ instance Binary Patt where put (PC x y) = putWord8 0 >> put (x,y) put (PP x y) = putWord8 1 >> put (x,y) put (PV x) = putWord8 2 >> put x - put (PW) = putWord8 3 put (PR x) = putWord8 4 >> put x put (PString x) = putWord8 5 >> put x put (PInt x) = putWord8 6 >> put x @@ -246,7 +245,6 @@ instance Binary Patt where 0 -> get >>= \(x,y) -> return (PC x y) 1 -> get >>= \(x,y) -> return (PP x y) 2 -> get >>= \x -> return (PV x) - 3 -> return (PW) 4 -> get >>= \x -> return (PR x) 5 -> get >>= \x -> return (PString x) 6 -> get >>= \x -> return (PInt x) diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs index bd0d2bf19..e3188c2ff 100644 --- a/src/compiler/api/GF/Grammar/Grammar.hs +++ b/src/compiler/api/GF/Grammar/Grammar.hs @@ -410,8 +410,7 @@ data Term = data Patt = PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ | PP QIdent [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@ - | PV Ident -- ^ variable pattern: @x@ - | PW -- ^ wild card pattern: @_@ + | PV Ident -- ^ variable pattern: @x@ or wild card @_@ | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete | PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract | PInt Integer -- ^ integer literal pattern: @12@ -- only abstract diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs index 65a48e213..e437ec081 100644 --- a/src/compiler/api/GF/Grammar/JSON.hs +++ b/src/compiler/api/GF/Grammar/JSON.hs @@ -198,7 +198,6 @@ json2term o = Vr <$> o!:"vr" patt2json (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))] patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))] patt2json (PV id) = makeObj [("pv",showJSON id)] -patt2json PW = makeObj [("wildcard",showJSON True)] patt2json (PR lbls) = makeObj (("record", showJSON True) : map toRow lbls) where toRow (l,t) = (showLabel l, patt2json t) patt2json (PString s) = showJSON s @@ -231,7 +230,6 @@ json2patt :: JSValue -> Result Patt json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt) <|> PC <$> (o!:"pc") <*> (o!:"args" >>= mapM json2patt) <|> PV <$> (o!:"pv") - <|> (o!:"wildcard" >>= guard >> return PW) <|> (const PR) <$> (o!:"record" >>= guard) <*> mapM fromRow (assocsJSObject o) <|> PString <$> readJSON o <|> PInt <$> readJSON o diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y index d8a06351f..cbd248782 100644 --- a/src/compiler/api/GF/Grammar/Parser.y +++ b/src/compiler/api/GF/Grammar/Parser.y @@ -536,7 +536,7 @@ Patt3 | '[' String ']' { PChars $2 } | '#' Ident { PMacro $2 } | '#' ModuleName '.' Ident { PM ($2,$4) } - | '_' { PW } + | '_' { PV identW } | Ident { PV $1 } | ModuleName '.' Ident { PP ($1,$3) [] } | Integer { PInt $1 } diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs index 4f14c6bb4..cdd99fdbb 100644 --- a/src/compiler/api/GF/Grammar/Printer.hs +++ b/src/compiler/api/GF/Grammar/Printer.hs @@ -293,7 +293,6 @@ ppPatt q d (PChar) = pp '?' ppPatt q d (PChars s) = brackets (str s) ppPatt q d (PMacro id) = '#' <> id ppPatt q d (PM id) = '#' <> ppQIdent q id -ppPatt q d PW = pp '_' ppPatt q d (PV id) = pp id ppPatt q d (PInt n) = pp n ppPatt q d (PFloat f) = pp f @@ -369,8 +368,6 @@ getAbs e = ([],e) getCTable :: Term -> ([Ident], Term) getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e in (v:vs,e') -getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e - in (identW:vs,e') getCTable e = ([],e) getLet :: Term -> ([LocalDef], Term)