mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-09-15 14:56:00 -06:00
more helpful error when lin X is missing
This commit is contained in:
@@ -31,6 +31,7 @@ import qualified GF.Grammar.Macros as C
|
|||||||
import GF.Data.ErrM(fromErr)
|
import GF.Data.ErrM(fromErr)
|
||||||
|
|
||||||
import Control.Monad.State.Strict(State,evalState,get,put)
|
import Control.Monad.State.Strict(State,evalState,get,put)
|
||||||
|
import Data.Maybe(isJust)
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
@@ -136,6 +137,6 @@ operIdent :: Int -> Ident
|
|||||||
operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) ---
|
operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) ---
|
||||||
|
|
||||||
isOperIdent :: Ident -> Bool
|
isOperIdent :: Ident -> Bool
|
||||||
isOperIdent id = isPrefixOf operPrefix (ident2raw id)
|
isOperIdent id = isJust (isPrefixOf operPrefix (ident2raw id))
|
||||||
|
|
||||||
operPrefix = rawIdentS ("A''")
|
operPrefix = rawIdentS ("A''")
|
||||||
|
|||||||
@@ -6,6 +6,7 @@ module GF.Compile.TypeCheck.Concrete ( checkLType, checkLType', inferLType, infe
|
|||||||
-- Practical type inference for arbitrary-rank types.
|
-- Practical type inference for arbitrary-rank types.
|
||||||
-- 14 September 2011
|
-- 14 September 2011
|
||||||
|
|
||||||
|
import Prelude hiding ((<>))
|
||||||
import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
|
import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
|
||||||
import GF.Grammar.Lookup
|
import GF.Grammar.Lookup
|
||||||
import GF.Grammar.Predef
|
import GF.Grammar.Predef
|
||||||
@@ -1083,15 +1084,21 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do -
|
|||||||
mkField scope l (mb_ty,t) (Just ty1) ty2 = do
|
mkField scope l (mb_ty,t) (Just ty1) ty2 = do
|
||||||
(t,ty1,ty2) <- subsCheckRho scope t ty1 ty2
|
(t,ty1,ty2) <- subsCheckRho scope t ty1 ty2
|
||||||
return ((l, (mb_ty,t)), (l, True, ty1))
|
return ((l, (mb_ty,t)), (l, True, ty1))
|
||||||
mkField scope l (mb_ty,t) Nothing ty2
|
mkField scope l (mb_ty,t) Nothing ty2 =
|
||||||
| isLockLabel l = return ((l, (Just (RecType []),R [])), (l, True, ty2))
|
case isLockLabel l of
|
||||||
| otherwise = return ((l, (mb_ty,t)), (l, True, ty2))
|
Just _ -> return ((l, (Just (RecType []),R [])), (l, True, ty2))
|
||||||
|
Nothing -> return ((l, (mb_ty,t)), (l, True, ty2))
|
||||||
|
|
||||||
(scope,mkProj,wrap) <- mkAccess scope t
|
(scope,mkProj,wrap) <- mkAccess scope t
|
||||||
|
|
||||||
let fields = [(l,o2,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
|
let fields = [(l,o2,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
|
||||||
case [l | (l,_,_,Nothing) <- fields, not ext1] of
|
case [l | (l,_,_,Nothing) <- fields, not ext1] of
|
||||||
[] -> return ()
|
[] -> return ()
|
||||||
|
[field] -> evalError ("In the term" <+> pp t $$
|
||||||
|
"there is no value for field" <+> field <>
|
||||||
|
case isLockLabel field of
|
||||||
|
Just cat -> ", try wrapping with lin"<+>pp cat
|
||||||
|
Nothing -> empty)
|
||||||
missing -> evalError ("In the term" <+> pp t $$
|
missing -> evalError ("In the term" <+> pp t $$
|
||||||
"there are no values for fields:" <+> hsep missing)
|
"there are no values for fields:" <+> hsep missing)
|
||||||
rs <- sequence [mkField scope l t mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t <- [mkProj l]]
|
rs <- sequence [mkField scope l t mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t <- [mkProj l]]
|
||||||
|
|||||||
@@ -40,9 +40,9 @@ lock c t = t
|
|||||||
lockLabel :: Ident -> Label
|
lockLabel :: Ident -> Label
|
||||||
lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
|
lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
|
||||||
|
|
||||||
isLockLabel :: Label -> Bool
|
isLockLabel :: Label -> Maybe RawIdent
|
||||||
isLockLabel l = case l of
|
isLockLabel l = case l of
|
||||||
LIdent c -> isPrefixOf lockPrefix c
|
LIdent c -> isPrefixOf lockPrefix c
|
||||||
_ -> False
|
_ -> Nothing
|
||||||
|
|
||||||
lockPrefix = rawIdentS "lock_"
|
lockPrefix = rawIdentS "lock_"
|
||||||
|
|||||||
@@ -26,7 +26,7 @@ module GF.Infra.Ident (-- ** Identifiers
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.ByteString.UTF8 as UTF8
|
import qualified Data.ByteString.UTF8 as UTF8
|
||||||
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
|
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf,drop,length)
|
||||||
-- Limit use of BS functions to the ones that work correctly on
|
-- Limit use of BS functions to the ones that work correctly on
|
||||||
-- UTF-8-encoded bytestrings!
|
-- UTF-8-encoded bytestrings!
|
||||||
import Data.Char(isDigit)
|
import Data.Char(isDigit)
|
||||||
@@ -75,7 +75,9 @@ rawIdentC = Id
|
|||||||
showRawIdent = unpack . rawId2utf8
|
showRawIdent = unpack . rawId2utf8
|
||||||
|
|
||||||
prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
|
prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
|
||||||
isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
|
isPrefixOf (Id x) (Id y)
|
||||||
|
| BS.isPrefixOf x y = Just (Id (BS.drop (BS.length x) y))
|
||||||
|
| otherwise = Nothing
|
||||||
|
|
||||||
instance Binary Ident where
|
instance Binary Ident where
|
||||||
put id = put (ident2utf8 id)
|
put id = put (ident2utf8 id)
|
||||||
|
|||||||
Reference in New Issue
Block a user