GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-19 16:12:52 -06:00
Code Issues Packages Projects Releases Wiki Activity

we can finally compile the English RGL

Browse Source
This commit is contained in:
krangelov
2021-10-20 19:39:02 +02:00
parent ad3489f0f9
commit b6047463a9
5 changed files with 254 additions and 146 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -19,7 +19,7 @@ module GF.Grammar.Lookup (
lookupIdent,
lookupOrigInfo,
allOrigInfos,
lookupResDef, lookupResDefLoc,
lookupResDef,
lookupResType,
lookupOverload,
lookupOverloadTypes,
@@ -64,26 +64,24 @@ lookupQIdentInfo :: ErrorMonad m => Grammar -> QIdent -> m Info
lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c)
| isPredefCat c = fmap noLoc (lock c defLinType)
lookupResDef gr (m,c)
| isPredefCat c = lock c defLinType
| otherwise = look m c
where
look m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
ResOper _ (Just lt) -> return lt
ResOper _ Nothing -> return (noLoc (Q (m,c)))
CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType)
ResOper _ (Just (L _ t)) -> return t
ResOper _ Nothing -> return (Q (m,c))
CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
CncCat _ _ _ _ _ -> lock c defLinType
CncFun (Just (_,cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
CncFun _ (Just ltr) _ _ -> return ltr
CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
CncFun _ (Just (L _ tr)) _ _ -> return tr
AnyInd _ n -> look n c
ResParam _ _ -> return (noLoc (QC (m,c)))
ResValue _ _ -> return (noLoc (QC (m,c)))
ResParam _ _ -> return (QC (m,c))
ResValue _ _ -> return (QC (m,c))
_ -> raise $ render (c <+> "is not defined in resource" <+> m)
lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type