mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 19:42:50 -06:00
lincat can now be just Str
This commit is contained in:
@@ -311,13 +311,15 @@ checkIfStrType st typ = case typ of
|
|||||||
checkIfLinType :: SourceGrammar -> Type -> Check Type
|
checkIfLinType :: SourceGrammar -> Type -> Check Type
|
||||||
checkIfLinType st typ0 = do
|
checkIfLinType st typ0 = do
|
||||||
typ <- computeLType st typ0
|
typ <- computeLType st typ0
|
||||||
|
{- ---- should check that not fun type
|
||||||
case typ of
|
case typ of
|
||||||
RecType r -> do
|
RecType r -> do
|
||||||
let (lins,ihs) = partition (isLinLabel .fst) r
|
let (lins,ihs) = partition (isLinLabel .fst) r
|
||||||
--- checkErr $ checkUnique $ map fst r
|
--- checkErr $ checkUnique $ map fst r
|
||||||
mapM_ checkInh ihs
|
mapM_ checkInh ihs
|
||||||
mapM_ checkLin lins
|
mapM_ checkLin lins
|
||||||
_ -> prtFail "a linearization type must be a record type instead of" typ
|
_ -> prtFail "a linearization type cannot be" typ
|
||||||
|
-}
|
||||||
return typ
|
return typ
|
||||||
|
|
||||||
where
|
where
|
||||||
@@ -1037,7 +1039,8 @@ linTypeOfType cnc m typ = do
|
|||||||
val <- lookLin mc
|
val <- lookLin mc
|
||||||
let vars = mkRecType varLabel $ replicate n typeStr
|
let vars = mkRecType varLabel $ replicate n typeStr
|
||||||
symb = argIdent n cat i
|
symb = argIdent n cat i
|
||||||
rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $
|
rec <- if n==0 then return val else
|
||||||
|
checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $
|
||||||
plusRecType vars val
|
plusRecType vars val
|
||||||
return (symb,rec)
|
return (symb,rec)
|
||||||
lookLin (_,c) = checks [ --- rather: update with defLinType ?
|
lookLin (_,c) = checks [ --- rather: update with defLinType ?
|
||||||
|
|||||||
@@ -440,8 +440,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
|
|||||||
Just vs -> (ty,[t |
|
Just vs -> (ty,[t |
|
||||||
(t,_) <- sortBy (\x y -> compare (snd x) (snd y))
|
(t,_) <- sortBy (\x y -> compare (snd x) (snd y))
|
||||||
(Map.assocs vs)])
|
(Map.assocs vs)])
|
||||||
_ -> error $ A.prt ty
|
_ -> error $ "doVar1" +++ A.prt ty
|
||||||
_ -> error $ A.prt tr
|
_ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug
|
||||||
updateSTM ((tyvs, (tr', tr)):)
|
updateSTM ((tyvs, (tr', tr)):)
|
||||||
return tr'
|
return tr'
|
||||||
_ -> GM.composOp doVar tr
|
_ -> GM.composOp doVar tr
|
||||||
|
|||||||
@@ -247,7 +247,8 @@ mkLinDefault :: SourceGrammar -> Type -> Err Term
|
|||||||
mkLinDefault gr typ = do
|
mkLinDefault gr typ = do
|
||||||
case unComputed typ of
|
case unComputed typ of
|
||||||
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
|
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
|
||||||
_ -> prtBad "linearization type must be a record type, not" typ
|
_ -> liftM (Abs strVar) $ mkDefField typ
|
||||||
|
---- _ -> prtBad "linearization type must be a record type, not" typ
|
||||||
where
|
where
|
||||||
mkDefField typ = case unComputed typ of
|
mkDefField typ = case unComputed typ of
|
||||||
Table p t -> do
|
Table p t -> do
|
||||||
|
|||||||
Reference in New Issue
Block a user