Commit f3a6e4bf authored by Camil Staps's avatar Camil Staps 🚀

Merge branch 'myriad-overlapping-instances' into 'master'

Fix the myriads of overlapping instances

See merge request !291
parents e18d7492 626d7b35
Pipeline #32005 passed with stage
in 3 minutes and 10 seconds
...@@ -27,7 +27,7 @@ from Text import <+, ...@@ -27,7 +27,7 @@ from Text import <+,
import Text.Language import Text.Language
import Text.Parsers.Simple.ParserCombinators import Text.Parsers.Simple.ParserCombinators
from Clean.Types import :: Type, :: TypeRestriction from Clean.Types import :: Type, :: TypeRestriction, :: TypeContext
from Clean.Types.Parse import parseType from Clean.Types.Parse import parseType
from Clean.Types.Util import instance toString Type from Clean.Types.Util import instance toString Type
...@@ -86,7 +86,7 @@ where ...@@ -86,7 +86,7 @@ where
toString {ParamDoc | description=Just d} = d toString {ParamDoc | description=Just d} = d
toString _ = "" toString _ = ""
derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, InstanceDoc, derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, InstanceDoc, TypeContext,
ClassMemberDoc, ConstructorDoc, ClassDoc, TypeDoc, Property, ClassMemberDoc, ConstructorDoc, ClassDoc, TypeDoc, Property,
PropertyVarInstantiation, MultiLineString, PropertyTestGenerator, ParamDoc PropertyVarInstantiation, MultiLineString, PropertyTestGenerator, ParamDoc
......
...@@ -47,7 +47,7 @@ from StdMaybe import :: Maybe ...@@ -47,7 +47,7 @@ from StdMaybe import :: Maybe
/** /**
* A type context. * A type context.
*/ */
:: TypeContext :== [TypeRestriction] :: TypeContext =: TypeContext [TypeRestriction]
/** /**
* A restriction on a type. * A restriction on a type.
...@@ -261,6 +261,13 @@ constructorsToFunctions :: !TypeDef -> [(String,Type,Maybe Priority)] ...@@ -261,6 +261,13 @@ constructorsToFunctions :: !TypeDef -> [(String,Type,Maybe Priority)]
*/ */
selectorsToFunctions :: !TypeDef -> [(String,Type)] selectorsToFunctions :: !TypeDef -> [(String,Type)]
/**
* Constructor for {{`TypeContext`}}.
*
* @type [TypeRestriction] -> TypeContext
*/
typeContext x :== TypeContext x
/** /**
* Wrapper around the {{`td_name`}} field of the {{`TypeDef`}} record. * Wrapper around the {{`td_name`}} field of the {{`TypeDef`}} record.
*/ */
......
...@@ -60,6 +60,10 @@ where ...@@ -60,6 +60,10 @@ where
KArrow a` b` -> a==a` && b==b` KArrow a` b` -> a==a` && b==b`
_ -> False _ -> False
instance == TypeContext
where
== (TypeContext a) (TypeContext b) = a == b
subtypes :: !Type -> [Type] subtypes :: !Type -> [Type]
subtypes t=:(Type s ts) = removeDup [t : flatten (map subtypes ts)] subtypes t=:(Type s ts) = removeDup [t : flatten (map subtypes ts)]
subtypes t=:(Func is r tc) = removeDup [t : flatten (map subtypes [r:is])] subtypes t=:(Func is r tc) = removeDup [t : flatten (map subtypes [r:is])]
...@@ -72,10 +76,10 @@ subtypes t=:(Strict t`) = [t:subtypes t`] ...@@ -72,10 +76,10 @@ subtypes t=:(Strict t`) = [t:subtypes t`]
allRestrictions :: !Type -> [TypeRestriction] allRestrictions :: !Type -> [TypeRestriction]
allRestrictions (Type _ ts) = concatMap allRestrictions ts allRestrictions (Type _ ts) = concatMap allRestrictions ts
allRestrictions (Func is r tc) = tc ++ concatMap allRestrictions [r:is] allRestrictions (Func is r (TypeContext tc)) = tc ++ concatMap allRestrictions [r:is]
allRestrictions (Cons _ ts) = concatMap allRestrictions ts allRestrictions (Cons _ ts) = concatMap allRestrictions ts
allRestrictions (Uniq t) = allRestrictions t allRestrictions (Uniq t) = allRestrictions t
allRestrictions (Forall _ t tc) = tc ++ allRestrictions t allRestrictions (Forall _ t (TypeContext tc)) = tc ++ allRestrictions t
allRestrictions (Var _) = [] allRestrictions (Var _) = []
allRestrictions (Arrow t) = fromMaybe [] (allRestrictions <$> t) allRestrictions (Arrow t) = fromMaybe [] (allRestrictions <$> t)
allRestrictions (Strict t) = allRestrictions t allRestrictions (Strict t) = allRestrictions t
...@@ -171,11 +175,11 @@ arity (Arrow _) = abort "what is the arity of Arrow?\n" // TODO ...@@ -171,11 +175,11 @@ arity (Arrow _) = abort "what is the arity of Arrow?\n" // TODO
removeTypeContexts :: !Type -> Type removeTypeContexts :: !Type -> Type
removeTypeContexts (Type s ts) = Type s $ map removeTypeContexts ts removeTypeContexts (Type s ts) = Type s $ map removeTypeContexts ts
removeTypeContexts (Func is r _) = Func (map removeTypeContexts is) (removeTypeContexts r) [] removeTypeContexts (Func is r _) = Func (map removeTypeContexts is) (removeTypeContexts r) (TypeContext [])
removeTypeContexts (Var v) = Var v removeTypeContexts (Var v) = Var v
removeTypeContexts (Cons v ts) = Cons v $ map removeTypeContexts ts removeTypeContexts (Cons v ts) = Cons v $ map removeTypeContexts ts
removeTypeContexts (Uniq t) = Uniq $ removeTypeContexts t removeTypeContexts (Uniq t) = Uniq $ removeTypeContexts t
removeTypeContexts (Forall ts t _) = Forall (map removeTypeContexts ts) (removeTypeContexts t) [] removeTypeContexts (Forall ts t _) = Forall (map removeTypeContexts ts) (removeTypeContexts t) (TypeContext [])
removeTypeContexts (Arrow t) = Arrow (removeTypeContexts <$> t) removeTypeContexts (Arrow t) = Arrow (removeTypeContexts <$> t)
removeTypeContexts (Strict t) = Strict (removeTypeContexts t) removeTypeContexts (Strict t) = Strict (removeTypeContexts t)
...@@ -192,7 +196,7 @@ where ...@@ -192,7 +196,7 @@ where
selectorsToFunctions :: !TypeDef -> [(String,Type)] selectorsToFunctions :: !TypeDef -> [(String,Type)]
selectorsToFunctions {td_name,td_uniq,td_args,td_rhs=TDRRecord _ _ fields} selectorsToFunctions {td_name,td_uniq,td_args,td_rhs=TDRRecord _ _ fields}
= [(f.rf_name, Func [strict arg] (unStrict f.rf_type) []) \\ f <- fields] = [(f.rf_name, Func [strict arg] (unStrict f.rf_type) (TypeContext [])) \\ f <- fields]
where where
arg = if td_uniq Uniq id $ Type td_name td_args arg = if td_uniq Uniq id $ Type td_name td_args
unStrict t = case t of unStrict t = case t of
...@@ -231,9 +235,9 @@ removeDupTypedefs [td:tds] ...@@ -231,9 +235,9 @@ removeDupTypedefs [td:tds]
= [td:removeDupTypedefs $ filter (\d -> d.td_name <> td.td_name) tds] = [td:removeDupTypedefs $ filter (\d -> d.td_name <> td.td_name) tds]
typeRhsRestrictions :: !TypeDefRhs -> [TypeRestriction] typeRhsRestrictions :: !TypeDefRhs -> [TypeRestriction]
typeRhsRestrictions (TDRCons _ cs) = flatten [c.cons_context \\ c <- cs] typeRhsRestrictions (TDRCons _ cs) = flatten [c \\ {cons_context=TypeContext c} <- cs]
typeRhsRestrictions (TDRNewType c) = c.cons_context typeRhsRestrictions (TDRNewType {cons_context=TypeContext c}) = c
typeRhsRestrictions (TDRMoreConses cs) = flatten [c.cons_context \\ c <- cs] typeRhsRestrictions (TDRMoreConses cs) = flatten [c \\ {cons_context=TypeContext c} <- cs]
typeRhsRestrictions (TDRRecord _ _ _) = [] typeRhsRestrictions (TDRRecord _ _ _) = []
typeRhsRestrictions (TDRSynonym _) = [] typeRhsRestrictions (TDRSynonym _) = []
typeRhsRestrictions (TDRAbstract _) = [] typeRhsRestrictions (TDRAbstract _) = []
......
...@@ -160,20 +160,20 @@ where ...@@ -160,20 +160,20 @@ where
uniq parser = pToken TStar >>| parser uniq parser = pToken TStar >>| parser
optContext :: Parser Token TypeContext optContext :: Parser Token TypeContext
optContext = liftM2 (++) (context <|> pure []) (uniquenessEqualities <|> pure []) optContext = liftM2 (\(TypeContext a) (TypeContext b)->TypeContext (a ++ b)) (context <|> pure (TypeContext [])) (uniquenessEqualities <|> pure (TypeContext []))
addContextAsConstFunction :: (Parser Token Type) -> Parser Token Type addContextAsConstFunction :: (Parser Token Type) -> Parser Token Type
addContextAsConstFunction parser = addContextAsConstFunction parser =
parser >>= \t -> pPeek >>= \tks -> case tks of parser >>= \t -> pPeek >>= \tks -> case tks of
[TPipe:_] -> (pure [] <|> optContext) >>= \c -> case c of [TPipe:_] -> (pure (TypeContext []) <|> optContext) >>= \c -> case c of
[] -> pure t TypeContext [] -> pure t
c -> pure $ Func [] t c c -> pure $ Func [] t c
_ -> pure t _ -> pure t
context :: Parser Token TypeContext context :: Parser Token TypeContext
context = pToken TPipe >>| flatten <$> pSepBy context` (pToken TAmpersand) context = pToken TPipe >>| typeContext o flatten <$> pSepBy context` (pToken TAmpersand)
where where
context` :: Parser Token TypeContext context` :: Parser Token [TypeRestriction]
context` = pSepBy classOrGeneric (pToken TComma) >>= \restrictions -> context` = pSepBy classOrGeneric (pToken TComma) >>= \restrictions ->
some argtype >>= \ts -> some argtype >>= \ts ->
mapM (flip ($) ts) restrictions mapM (flip ($) ts) restrictions
...@@ -201,7 +201,7 @@ where ...@@ -201,7 +201,7 @@ where
_ -> False _ -> False
uniquenessEqualities :: Parser Token TypeContext uniquenessEqualities :: Parser Token TypeContext
uniquenessEqualities = pToken TComma >>| bracked (pSepBy inequality (pToken TComma)) $> [] uniquenessEqualities = pToken TComma >>| bracked (pSepBy inequality (pToken TComma)) $> TypeContext []
where where
inequality = unqvar >>| pToken TLtEq >>| unqvar inequality = unqvar >>| pToken TLtEq >>| unqvar
......
...@@ -21,11 +21,11 @@ import Text.GenJSON ...@@ -21,11 +21,11 @@ import Text.GenJSON
instance zero (TypeTree v) where zero = Node (Var "ra") [] [] instance zero (TypeTree v) where zero = Node (Var "ra") [] []
instance < (TypeTree v) where < (Node a _ _) (Node b _ _) = a < b instance < (TypeTree v) where < (Node a _ _) (Node b _ _) = a < b
derive gLexOrd Type, Maybe, TypeRestriction derive gLexOrd Type, Maybe, TypeRestriction, TypeContext
instance < Type where < t u = (t =?= u) =: LT instance < Type where < t u = (t =?= u) =: LT
derive JSONEncode TypeTree, Type, TypeRestriction derive JSONEncode TypeTree, Type, TypeRestriction, TypeContext
derive JSONDecode TypeTree, Type, TypeRestriction derive JSONDecode TypeTree, Type, TypeRestriction, TypeContext
typeTreeNodes :: !(TypeTree v) -> Int typeTreeNodes :: !(TypeTree v) -> Int
typeTreeNodes (Node _ _ cs) = 1 + sum (map typeTreeNodes cs) typeTreeNodes (Node _ _ cs) = 1 + sum (map typeTreeNodes cs)
......
...@@ -20,7 +20,7 @@ import Data.List ...@@ -20,7 +20,7 @@ import Data.List
from Data.Map import :: Map, newMap from Data.Map import :: Map, newMap
import Data.Maybe import Data.Maybe
derive gEq Type, TypeRestriction, Kind derive gEq Type, TypeRestriction, Kind, TypeContext
isGeneralisingUnifier :: ![TVAssignment] -> Bool isGeneralisingUnifier :: ![TVAssignment] -> Bool
isGeneralisingUnifier tvas = all isOk $ groupVars tvas [] isGeneralisingUnifier tvas = all isOk $ groupVars tvas []
...@@ -74,7 +74,7 @@ where ...@@ -74,7 +74,7 @@ where
renameAndRemoveStrictness (Var v) = Var (prep +++ v) renameAndRemoveStrictness (Var v) = Var (prep +++ v)
renameAndRemoveStrictness (Cons c ts) = Cons (prep +++ c) $ map renameAndRemoveStrictness ts renameAndRemoveStrictness (Cons c ts) = Cons (prep +++ c) $ map renameAndRemoveStrictness ts
renameAndRemoveStrictness (Type t ts) = Type t $ map renameAndRemoveStrictness ts renameAndRemoveStrictness (Type t ts) = Type t $ map renameAndRemoveStrictness ts
renameAndRemoveStrictness (Func is r tc) = Func (map renameAndRemoveStrictness is) (renameAndRemoveStrictness r) (map (inTC renameAndRemoveStrictness) tc) renameAndRemoveStrictness (Func is r (TypeContext tc)) = Func (map renameAndRemoveStrictness is) (renameAndRemoveStrictness r) (TypeContext (map (inTC renameAndRemoveStrictness) tc))
renameAndRemoveStrictness (Uniq t) = Uniq $ renameAndRemoveStrictness t renameAndRemoveStrictness (Uniq t) = Uniq $ renameAndRemoveStrictness t
renameAndRemoveStrictness (Arrow t) = Arrow (renameAndRemoveStrictness <$> t) renameAndRemoveStrictness (Arrow t) = Arrow (renameAndRemoveStrictness <$> t)
renameAndRemoveStrictness (Forall vs t tc) = fromJust $ renameAndRemoveStrictness (Forall vs t tc) = fromJust $
......
...@@ -57,8 +57,8 @@ where ...@@ -57,8 +57,8 @@ where
instance print TypeContext instance print TypeContext
where where
print _ [] = [] print _ (TypeContext []) = []
print _ crs = printersperse False " & " print _ (TypeContext crs) = printersperse False " & "
[printersperse False ", " (map corg gr) -- " " -- printersperse False " " (types $ hd gr) \\ gr <- grps] [printersperse False ", " (map corg gr) -- " " -- printersperse False " " (types $ hd gr) \\ gr <- grps]
where where
grps = groupBy (\a b -> types a == types b && length (types a) == 1) crs grps = groupBy (\a b -> types a == types b && length (types a) == 1) crs
...@@ -69,16 +69,16 @@ instance print Type ...@@ -69,16 +69,16 @@ instance print Type
where where
print ia (Type s vs) = typeConstructorName True ia s vs print ia (Type s vs) = typeConstructorName True ia s vs
print _ (Var v) = [v] print _ (Var v) = [v]
print ia (Func [] r []) = print ia r print ia (Func [] r (TypeContext [])) = print ia r
print _ (Func [] r tc) = r -- " | " -- tc print _ (Func [] r tc) = r -- " | " -- tc
print ia (Func ts r []) = parens ia (printersperse True " " ts -- " -> " -- r) print ia (Func ts r (TypeContext [])) = parens ia (printersperse True " " ts -- " -> " -- r)
print _ (Func ts r tc) = (Func ts r []) -- " | " -- tc print _ (Func ts r tc) = (Func ts r (TypeContext [])) -- " | " -- tc
print ia (Cons tv []) = print ia tv print ia (Cons tv []) = print ia tv
print ia (Cons tv ats) = parens ia (tv -- " " -- printersperse True " " ats) print ia (Cons tv ats) = parens ia (tv -- " " -- printersperse True " " ats)
print _ (Uniq t) = case t of print _ (Uniq t) = case t of
Type _ _ -> "*" -- t Type _ _ -> "*" -- t
_ -> "*" -+ t _ -> "*" -+ t
print _ (Forall tvs t []) = "(A." -- printersperse True " " tvs -- ": " -- t -- ")" print _ (Forall tvs t (TypeContext [])) = "(A." -- printersperse True " " tvs -- ": " -- t -- ")"
print _ (Forall tvs t tc) = "(A." -- printersperse True " " tvs -- ": " -- t -- " | " -- tc -- ")" print _ (Forall tvs t tc) = "(A." -- printersperse True " " tvs -- ": " -- t -- " | " -- tc -- ")"
print _ (Arrow Nothing) = ["(->)"] print _ (Arrow Nothing) = ["(->)"]
print _ (Arrow (Just t)) = "((->) " -+ t +- ")" print _ (Arrow (Just t)) = "((->) " -+ t +- ")"
...@@ -161,10 +161,10 @@ where ...@@ -161,10 +161,10 @@ where
instance print Constructor instance print Constructor
where where
print _ {cons_name,cons_args,cons_exi_vars=evars,cons_context,cons_priority} print _ {cons_name,cons_args,cons_exi_vars=evars,cons_context=TypeContext c,cons_priority}
= if (isEmpty evars) [] ("E." -- printersperse False " " evars -- ": ") -- = if (isEmpty evars) [] ("E." -- printersperse False " " evars -- ": ") --
name -- " " -- prio -- printersperse True " " cons_args -- name -- " " -- prio -- printersperse True " " cons_args --
if (isEmpty cons_context) [] (" & " -- cons_context) if (isEmpty c) [] (" & " -- c)
where where
(name,prio) = case cons_priority of (name,prio) = case cons_priority of
Nothing -> ([cons_name], []) Nothing -> ([cons_name], [])
...@@ -264,7 +264,7 @@ assign va (Arrow Nothing) = Just $ Arrow Nothing ...@@ -264,7 +264,7 @@ assign va (Arrow Nothing) = Just $ Arrow Nothing
assign va (Strict t) = Strict <$> assign va t assign va (Strict t) = Strict <$> assign va t
reduceArities :: !Type -> Type reduceArities :: !Type -> Type
reduceArities (Func [] r []) = r reduceArities (Func [] r (TypeContext [])) = r
reduceArities (Func ts r tc) reduceArities (Func ts r tc)
| length ts > 1 = Func [reduceArities $ hd ts] (reduceArities $ Func (tl ts) r tc) tc | length ts > 1 = Func [reduceArities $ hd ts] (reduceArities $ Func (tl ts) r tc) tc
| otherwise = Func (map reduceArities ts) (reduceArities r) tc | otherwise = Func (map reduceArities ts) (reduceArities r) tc
...@@ -272,7 +272,7 @@ reduceArities (Type s ts) = Type s $ map reduceArities ts ...@@ -272,7 +272,7 @@ reduceArities (Type s ts) = Type s $ map reduceArities ts
reduceArities (Cons v ts) = Cons v $ map reduceArities ts reduceArities (Cons v ts) = Cons v $ map reduceArities ts
reduceArities (Uniq t) = Uniq $ reduceArities t reduceArities (Uniq t) = Uniq $ reduceArities t
reduceArities (Var v) = Var v reduceArities (Var v) = Var v
reduceArities (Forall [] t []) = reduceArities t reduceArities (Forall [] t (TypeContext [])) = reduceArities t
reduceArities (Forall tvs t tc) = Forall tvs (reduceArities t) tc reduceArities (Forall tvs t tc) = Forall tvs (reduceArities t) tc
reduceArities (Arrow mt) = Arrow (reduceArities <$> mt) reduceArities (Arrow mt) = Arrow (reduceArities <$> mt)
reduceArities (Strict t) = Strict $ reduceArities t reduceArities (Strict t) = Strict $ reduceArities t
...@@ -293,14 +293,14 @@ where ...@@ -293,14 +293,14 @@ where
renames = [(o, "v" +++ toString n) \\ o <- removeDup $ allVars t & n <- [1..]] renames = [(o, "v" +++ toString n) \\ o <- removeDup $ allVars t & n <- [1..]]
renameVars :: !Type -> Type renameVars :: !Type -> Type
renameVars (Type s ts) = Type s $ map renameVars ts renameVars (Type s ts) = Type s $ map renameVars ts
renameVars (Func is r tc) = Func (map renameVars is) (renameVars r) $ map renameVarsInTC tc renameVars (Func is r (TypeContext tc)) = Func (map renameVars is) (renameVars r) $ TypeContext (map renameVarsInTC tc)
renameVars (Var tv) = Var $ fromJust $ lookup tv renames renameVars (Var tv) = Var $ fromJust $ lookup tv renames
renameVars (Cons cv ts) = Cons (fromJust $ lookup cv renames) $ map renameVars ts renameVars (Cons cv ts) = Cons (fromJust $ lookup cv renames) $ map renameVars ts
renameVars (Uniq t) = Uniq $ renameVars t renameVars (Uniq t) = Uniq $ renameVars t
renameVars (Forall vs t tc) = Forall (map renameVars vs) (renameVars t) $ map renameVarsInTC tc renameVars (Forall vs t (TypeContext tc)) = Forall (map renameVars vs) (renameVars t) $ TypeContext (map renameVarsInTC tc)
renameVars (Arrow t) = Arrow $ renameVars <$> t renameVars (Arrow t) = Arrow $ renameVars <$> t
renameVars (Strict t) = Strict $ renameVars t renameVars (Strict t) = Strict $ renameVars t
renameVarsInTC :: !TypeRestriction -> TypeRestriction renameVarsInTC :: !TypeRestriction -> TypeRestriction
renameVarsInTC (Instance c ts) = Instance c $ map renameVars ts renameVarsInTC (Instance c ts) = Instance c $ map renameVars ts
...@@ -321,15 +321,15 @@ where ...@@ -321,15 +321,15 @@ where
allVars` = concatMap allVars allVars` = concatMap allVars
optConses :: !Type -> Type optConses :: !Type -> Type
optConses (Type s ts) = Type s $ map optConses ts optConses (Type s ts) = Type s $ map optConses ts
optConses (Func is r tc) = Func (map optConses is) (optConses r) $ map optConsesInTR tc optConses (Func is r (TypeContext tc)) = Func (map optConses is) (optConses r) $ TypeContext (map optConsesInTR tc)
optConses (Var v) = Var v optConses (Var v) = Var v
optConses (Cons c []) = Var c optConses (Cons c []) = Var c
optConses (Cons c ts) = Cons c $ map optConses ts optConses (Cons c ts) = Cons c $ map optConses ts
optConses (Uniq t) = Uniq $ optConses t optConses (Uniq t) = Uniq $ optConses t
optConses (Forall vs t tc) = Forall (map optConses vs) (optConses t) $ map optConsesInTR tc optConses (Forall vs t (TypeContext tc)) = Forall (map optConses vs) (optConses t) $ TypeContext (map optConsesInTR tc)
optConses (Arrow t) = Arrow $ optConses <$> t optConses (Arrow t) = Arrow $ optConses <$> t
optConses (Strict t) = Strict $ optConses t optConses (Strict t) = Strict $ optConses t
optConsesInTR :: !TypeRestriction -> TypeRestriction optConsesInTR :: !TypeRestriction -> TypeRestriction
optConsesInTR (Instance c ts) = Instance c $ map optConses ts optConsesInTR (Instance c ts) = Instance c $ map optConses ts
......
...@@ -30,7 +30,8 @@ mapArr :: !(a -> a) !(arr a) -> arr a | Array arr a ...@@ -30,7 +30,8 @@ mapArr :: !(a -> a) !(arr a) -> arr a | Array arr a
appendArr :: !(arr a) !(arr a) -> arr a | Array arr a appendArr :: !(arr a) !(arr a) -> arr a | Array arr a
instance +++ (arr a) | Array arr a instance +++ {a}
instance +++ {!a}
instance Functor {} where fmap :: (a -> b) !{a} -> {b} instance Functor {} where fmap :: (a -> b) !{a} -> {b}
instance Functor {!} where fmap :: (a -> b) !{!a} -> {!b} instance Functor {!} where fmap :: (a -> b) !{!a} -> {!b}
......
...@@ -111,7 +111,9 @@ appendArr l r ...@@ -111,7 +111,9 @@ appendArr l r
addWithOffset totalSz offset oldArr newArr addWithOffset totalSz offset oldArr newArr
= foldrArrWithKey (\idx oldEl newArr -> {newArr & [idx + offset] = oldEl}) newArr oldArr = foldrArrWithKey (\idx oldEl newArr -> {newArr & [idx + offset] = oldEl}) newArr oldArr
instance +++ (arr a) | Array arr a where instance +++ {a} where
(+++) l r = appendArr l r
instance +++ {!a} where
(+++) l r = appendArr l r (+++) l r = appendArr l r
instance Functor {} instance Functor {}
......
definition module Data.List definition module Data.List
from StdClass import class Ord, class Eq, class IncDec from StdClass import class Ord, class Eq, class IncDec
from StdOverloaded import class ==, class <, class length, class %, class toString, class toChar, class fromString, class fromChar, class +, class *, class /, class *, class /, class *, class /, class *, class /, class zero, class one, class - from StdOverloaded import class ==, class <, class length, class %, class toString, class toChar, class fromString, class fromChar, class +, class *, class /, class *, class /, class *, class /, class *, class /, class zero, class one, class -, class +++
import StdList import StdList
from Data.GenEq import generic gEq from Data.GenEq import generic gEq
...@@ -25,6 +25,8 @@ instance Monoid [a] ...@@ -25,6 +25,8 @@ instance Monoid [a]
instance Foldable [] instance Foldable []
instance Traversable [] instance Traversable []
instance +++ [a]
/** /**
* An element in the list, or Nothing if it does not exist. * An element in the list, or Nothing if it does not exist.
*/ */
......
...@@ -70,6 +70,10 @@ instance Traversable [] ...@@ -70,6 +70,10 @@ instance Traversable []
where where
traverse f x = foldr (\x ys->(\x xs->[x:xs]) <$> f x <*> ys) (pure []) x traverse f x = foldr (\x ys->(\x xs->[x:xs]) <$> f x <*> ys) (pure []) x
instance +++ [a]
where
(+++) a b = a ++ b
(!?) infixl 9 :: ![.a] !Int -> Maybe .a (!?) infixl 9 :: ![.a] !Int -> Maybe .a
(!?) [x:_] 0 = Just x (!?) [x:_] 0 = Just x
(!?) [_:xs] i = xs !? (i-1) (!?) [_:xs] i = xs !? (i-1)
......
...@@ -6,6 +6,7 @@ from Data.Monoid import class Semigroup, class Monoid ...@@ -6,6 +6,7 @@ from Data.Monoid import class Semigroup, class Monoid
from Data.Foldable import class Foldable from Data.Foldable import class Foldable
from Data.Traversable import class Traversable from Data.Traversable import class Traversable
from Data.Bifunctor import class Bifunctor from Data.Bifunctor import class Bifunctor
from StdOverloaded import class toString
tuple :: .a .b -> .(.a,.b) tuple :: .a .b -> .(.a,.b)
tuple3 :: .a .b .c -> .(.a,.b,.c) tuple3 :: .a .b .c -> .(.a,.b,.c)
...@@ -59,3 +60,8 @@ instance Bifunctor (,) ...@@ -59,3 +60,8 @@ instance Bifunctor (,)
instance Bifunctor ((,,) x) instance Bifunctor ((,,) x)
instance Bifunctor ((,,,) x y) instance Bifunctor ((,,,) x y)
instance Bifunctor ((,,,,) x y z) instance Bifunctor ((,,,,) x y z)
instance toString (a, b) | toString a & toString b
instance toString (a, b, c) | toString a & toString b & toString c
instance toString (a, b, c, d) | toString a & toString b & toString c & toString d
instance toString (a, b, c, d, e) | toString a & toString b & toString c & toString d & toString e
...@@ -9,6 +9,10 @@ import Data.Monoid ...@@ -9,6 +9,10 @@ import Data.Monoid
import Data.Foldable import Data.Foldable
import Data.Traversable import Data.Traversable
import Control.Applicative import Control.Applicative
import StdOverloaded
import StdString
from Text import class Text, instance Text String
import qualified Text
tuple :: .a .b -> .(.a,.b) tuple :: .a .b -> .(.a,.b)
tuple a b = (a,b) tuple a b = (a,b)
...@@ -132,3 +136,19 @@ where ...@@ -132,3 +136,19 @@ where
instance Bifunctor ((,,,,) x y z) instance Bifunctor ((,,,,) x y z)
where where
bifmap f g t = let (x, y, z, a, b) = t in (x, y, z, f a, g b) bifmap f g t = let (x, y, z, a, b) = t in (x, y, z, f a, g b)
instance toString (a, b) | toString a & toString b
where
toString (a, b) = 'Text'.concat ["(", toString a, ", ", toString b, ")"]
instance toString (a, b, c) | toString a & toString b & toString c
where
toString (a, b, c) = 'Text'.concat ["(", toString a, ", ", toString b, ", ", toString c, ")"]
instance toString (a, b, c, d) | toString a & toString b & toString c & toString d
where
toString (a, b, c, d) = 'Text'.concat ["(", toString a, ", ", toString b, ", ", toString c, ", ", toString d, ")"]