Commit 4a3061ff authored by Steffen Michels's avatar Steffen Michels

don't use newtype constructors OBJECT & FIELD without arguments

parent 23221a33
Pipeline #16551 passed with stage
in 2 minutes and 50 seconds
......@@ -149,7 +149,7 @@ docBlockToDoc{|EITHER|} fl fr doc = case fl doc of
Left e -> case fr doc of
Right (v, ws) -> Right (RIGHT v, ws)
Left _ -> Left e
docBlockToDoc{|OBJECT|} fx doc = appFst OBJECT <$> fx doc
docBlockToDoc{|OBJECT|} fx doc = appFst (\x -> OBJECT x) <$> fx doc
docBlockToDoc{|MultiLineString|} (Left [s]) = Right (MultiLine $ trimMultiLine $ split "\n" s, [])
docBlockToDoc{|MultiLineString|} _ = abort "error in docBlockToDoc{|MultiLineString|}\n"
......
implementation module Control.GenMonad
import StdGeneric, StdList, StdFunc
from Data.Func import $
from Data.Maybe import :: Maybe(..)
generic gMapLM a b :: a:a -> m:(m b:b) | Monad m, [m <= b]
......@@ -9,8 +10,8 @@ gMapLM{|UNIT|} _ = ret UNIT
gMapLM{|PAIR|} fx fy (PAIR x y) = fx x >>= \x1 -> fy y >>= \y1 -> ret (PAIR x1 y1)
gMapLM{|EITHER|} fl fr x = mapMEITHER fl fr x
gMapLM{|CONS|} f (CONS x) = f x >>= ret o CONS
gMapLM{|FIELD|} f (FIELD x) = f x >>= ret o FIELD
gMapLM{|OBJECT|} f (OBJECT x) = f x >>= ret o OBJECT
gMapLM{|FIELD|} f (FIELD x) = f x >>= \x -> ret $ FIELD x
gMapLM{|OBJECT|} f (OBJECT x) = f x >>= \x -> ret $ OBJECT x
generic gMapRM a b :: a:a -> m:(m b:b) | Monad m, [m <= b]
gMapRM{|c|} x = ret x
......@@ -18,8 +19,8 @@ gMapRM{|UNIT|} _ = ret UNIT
gMapRM{|PAIR|} fx fy (PAIR x y) = fy y >>= \y1 -> fx x >>= \x1 -> ret (PAIR x1 y1)
gMapRM{|EITHER|} fl fr x = mapMEITHER fl fr x
gMapRM{|CONS|} f (CONS x) = f x >>= ret o CONS
gMapRM{|FIELD|} f (FIELD x) = f x >>= ret o FIELD
gMapRM{|OBJECT|} f (OBJECT x) = f x >>= ret o OBJECT
gMapRM{|FIELD|} f (FIELD x) = f x >>= \x -> ret $ FIELD x
gMapRM{|OBJECT|} f (OBJECT x) = f x >>= \x -> ret $ OBJECT x
derive gMapLM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
derive gMapRM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
......
......@@ -2,7 +2,7 @@ implementation module Data.GenCompress
import StdGeneric, StdEnv
from Data.Maybe import :: Maybe(..)
import Data._Array
import Data._Array, Data.Func
//--------------------------------------------------
// uncompressor monad
......@@ -200,8 +200,8 @@ where
= fr >>= ret o RIGHT
= fl >>= ret o LEFT
gUncompress{|CONS|} f = f >>= ret o CONS
gUncompress{|FIELD|} f = f >>= ret o FIELD
gUncompress{|OBJECT|} f = f >>= ret o OBJECT
gUncompress{|FIELD|} f = f >>= \x -> ret $ FIELD x
gUncompress{|OBJECT|} f = f >>= \x -> ret $ OBJECT x
gUncompress{|[]|} f = uncompressList f
gUncompress{|{}|} f = uncompressArray f
gUncompress{|{!}|} f = uncompressArray f
......
......@@ -88,9 +88,9 @@ conses{|CONS|} f = [CONS (hd f)]
conses{|UNIT|} = [UNIT]
conses{|PAIR|} f g = [PAIR x y \\ x <- f, y <- g]
conses{|EITHER|} f g = map LEFT f ++ map RIGHT g
conses{|OBJECT|} f = map OBJECT f
conses{|OBJECT|} f = map (\x -> OBJECT x) f
conses{|RECORD|} f = map RECORD f
conses{|FIELD|} f = map FIELD f
conses{|FIELD|} f = map (\x -> FIELD x) f
conses{|Int|} = [0]
conses{|Bool|} = [True]
conses{|Char|} = ['\0']
......
......@@ -44,9 +44,9 @@ gFiniteDefault{|UNIT|} = [Just UNIT]
gFiniteDefault{|EITHER|} dsl dsr = [(LEFT <$> dl) <|> (RIGHT <$> dr) \\ dl <- dsl & dr <- dsr]
gFiniteDefault{|PAIR|} dsl dsr = [PAIR <$> dl <*> dr \\ dl <- dsl, dr <- dsr]
gFiniteDefault{|CONS|} dc = fmap CONS <$> dc
gFiniteDefault{|FIELD|} df = fmap FIELD <$> df
gFiniteDefault{|FIELD|} df = fmap (\x -> FIELD x) <$> df
// add a Nothing for each level to prevent infinite recursion to produce list elements for infinite branches
gFiniteDefault{|OBJECT|} do = [Nothing: fmap OBJECT <$> do]
gFiniteDefault{|OBJECT|} do = [Nothing: fmap (\x -> OBJECT x) <$> do]
gFiniteDefault{|RECORD|} dr = fmap RECORD <$> dr
derive gFiniteDefault (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
......@@ -12,7 +12,7 @@ gFDomain{|UNIT|} = [UNIT]
gFDomain{|PAIR|} dx dy = [PAIR x y\\x <- dx, y <- dy]
gFDomain{|EITHER|} dx dy = map LEFT dx ++ map RIGHT dy
gFDomain{|CONS|} dx = map CONS dx
gFDomain{|FIELD|} dx = map FIELD dx
gFDomain{|OBJECT|} dx = map OBJECT dx
gFDomain{|FIELD|} dx = map (\x -> FIELD x) dx
gFDomain{|OBJECT|} dx = map (\x -> OBJECT x) dx
derive gFDomain (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
......@@ -34,8 +34,8 @@ gMaybeZip{|EITHER|} fl fr (LEFT x) (LEFT y) = mapMaybe LEFT (fl x y)
gMaybeZip{|EITHER|} fl fr (RIGHT x) (RIGHT y) = mapMaybe RIGHT (fr x y)
gMaybeZip{|EITHER|} fl fr _ _ = Nothing
gMaybeZip{|CONS|} f (CONS x) (CONS y) = mapMaybe CONS (f x y)
gMaybeZip{|FIELD|} f (FIELD x) (FIELD y) = mapMaybe FIELD (f x y)
gMaybeZip{|OBJECT|} f (OBJECT x) (OBJECT y) = mapMaybe OBJECT (f x y)
gMaybeZip{|FIELD|} f (FIELD x) (FIELD y) = mapMaybe (\x -> FIELD x) (f x y)
gMaybeZip{|OBJECT|} f (OBJECT x) (OBJECT y) = mapMaybe (\x -> OBJECT x) (f x y)
derive gMaybeZip [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
zipMaybe :: .(.a -> .(.b -> .c)) !(Maybe .a) (Maybe .b) -> (Maybe .c)
......
......@@ -417,7 +417,7 @@ gIRCParse{|EITHER|} lp rp as = case lp as of
(Left e1, _) = case rp as of
(Right a, rest) = (Right $ RIGHT a, rest)
(Left e2, _) = (Left $ e2, [])
gIRCParse{|OBJECT|} p as = appFst (fmap OBJECT) $ p as
gIRCParse{|OBJECT|} p as = appFst (fmap $ \x -> OBJECT x) $ p as
gIRCParse{|CONS of d|} p []
= (Left $ concat ["Expected a cmd constructor: ", d.gcd_name], [])
gIRCParse{|CONS of d|} p [a:as]
......
......@@ -674,17 +674,17 @@ mkprod exprs
gParse{|FIELD of {gfd_name}|} parse_arg (ExprField name value)
| gfd_name == name
= mapMaybe FIELD (parse_arg value)
= mapMaybe (\x -> FIELD x) (parse_arg value)
= Nothing
gParse{|FIELD of {gfd_name}|} _ _ = Nothing
gParse{|OBJECT of {gtd_num_conses,gtd_conses}|} parse_arg expr
| gtd_num_conses == 0 = case expr of
ExprApp ap
| size ap == 2 && is_ident (hd gtd_conses).gcd_name ap.[0]
= mapMaybe OBJECT (parse_arg ap.[1])
= mapMaybe (\x -> OBJECT x) (parse_arg ap.[1])
= Nothing
_ = Nothing
= mapMaybe OBJECT (parse_arg expr)
= mapMaybe (\x -> OBJECT x) (parse_arg expr)
gParse{|[]|} parse_arg (ExprList exprs)
= maybeAll [parse_arg e \\e<-exprs]
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment