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

GF.Grammar.Canonical: some Functor/Foldable/Traversable instances

Browse Source
This commit is contained in:
Thomas Hallgren
2019-03-13 01:51:26 +01:00
parent ba9aeb3322
commit b11d7d93dc
4 changed files with 24 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -194,8 +194,8 @@ concrete2haskell opts
else LambdaCase (map ppCase cs)
where
(ds,ts') = dedup ts
(ps,ts) = unzip [(p,t)|TableRowValue p t<-cs]
ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t)
(ps,ts) = unzip [(p,t)|TableRow p t<-cs]
ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
{-
ppPredef n =
case predef n of
@@ -309,8 +309,8 @@ instance Records LinValue where
Selection v1 v2 -> records (v1,v2)
_ -> S.empty
instance Records TableRowValue where
records (TableRowValue _ v) = records v
instance Records rhs => Records (TableRow rhs) where
records (TableRow _ v) = records v
-- | Record subtyping is converted into explicit coercions in Haskell
@@ -318,7 +318,7 @@ coerce env ty t =
case (ty,t) of
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-cs]
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) |
RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]

10
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -151,7 +151,7 @@ convert' gr vs = ppT
case t of
-- Abs b x t -> ...
-- V ty ts -> VTableValue (convType ty) (map ppT ts)
V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts]
V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
where
Ok pts = allParamValues gr ty
Ok ps = mapM term2patt pts
@@ -174,7 +174,7 @@ convert' gr vs = ppT
Alts t' vs -> alts vs (ppT t')
_ -> error $ "convert' "++show t
ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t)
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
ppPredef n =
case predef n of
@@ -249,19 +249,19 @@ proj r l =
selection t v =
case t of
TableValue tt r ->
case nub [rv|TableRowValue _ rv<-keep] of
case nub [rv|TableRow _ rv<-keep] of
[rv] -> rv
_ -> Selection (TableValue tt r') v
where
r' = if null discard
then r
else keep++[TableRowValue WildPattern impossible]
else keep++[TableRow WildPattern impossible]
(keep,discard) = partition (mightMatchRow v) r
_ -> Selection t v
impossible = ErrorValue "impossible"
mightMatchRow v (TableRowValue p _) =
mightMatchRow v (TableRow p _) =
case p of
WildPattern -> True
_ -> mightMatch v p