Commit 642bf63d authored by Steffen Michels's avatar Steffen Michels

Merge branch '61-add-checks-for-functions-with-missing-alternatives' into 'master'

Resolve "Add checks for functions with missing alternatives"

Closes #61

See merge request !210
parents 19d9260c 2a6bd920
Pipeline #15356 passed with stage
in 1 minute and 13 seconds
......@@ -253,7 +253,7 @@ parseDoc :: !String -> Either ParseError (!d, ![ParseWarning]) | docBlockToDoc{|
*/
generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d, ![ParseWarning])
derive docBlockToDoc UNIT, PAIR, EITHER, CONS, OBJECT, FIELD of d, RECORD
derive docBlockToDoc UNIT, PAIR, EITHER, CONS, OBJECT, FIELD of {gfd_name}, RECORD
derive docBlockToDoc String, [], Maybe, Type
derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc,
ConstructorDoc, TypeDoc
......
......@@ -114,14 +114,18 @@ parseDoc s = docBlockToDoc{|*|} (Left [s])
generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d, ![ParseWarning])
docBlockToDoc{|String|} (Left []) = Left InternalNoDataError
docBlockToDoc{|String|} (Left ss) = Right (trim $ last ss, [])
docBlockToDoc{|String|} _ = abort "error in docBlockToDoc{|String|}\n"
docBlockToDoc{|[]|} fx (Left ss) = (\vws -> (map fst vws, flatten (map snd vws)) ) <$> mapM fx (map (Left o pure) ss)
docBlockToDoc{|Maybe|} fx (Left []) = Right (Nothing, [])
docBlockToDoc{|[]|} _ _ = abort "error in docBlockToDoc{|[]|}\n"
docBlockToDoc{|Maybe|} fx (Left []) = Right (Nothing, [])
docBlockToDoc{|Maybe|} fx ss=:(Left _) = appFst Just <$> fx ss
docBlockToDoc{|Maybe|} _ _ = abort "error in docBlockToDoc{|Maybe|}\n"
docBlockToDoc{|UNIT|} _ = Right (UNIT, [])
docBlockToDoc{|PAIR|} fx fy db=:(Right _) = liftA2 (\(x,ws) (y,ws`) -> (PAIR x y, ws ++ ws`)) (fx db) (fy db)
docBlockToDoc{|FIELD of d|} fx (Right db) = case fx (Left [v \\ (k,v) <- db | k matches d.gfd_name]) of
docBlockToDoc{|PAIR|} _ _ _ = abort "error in docBlockToDoc{|PAIR|}\n"
docBlockToDoc{|FIELD of {gfd_name}|} fx (Right db) = case fx (Left [v \\ (k,v) <- db | k matches gfd_name]) of
Right (f, ws) -> Right (FIELD f, ws)
Left InternalNoDataError -> Left (MissingField d.gfd_name)
Left InternalNoDataError -> Left (MissingField gfd_name)
Left e -> Left e
where
(matches) infix 4 :: !String !String -> Bool
......@@ -132,6 +136,7 @@ where
k` == "return" && name == "results"
where
k` = {if (c == '-') '_' c \\ c <-: k}
docBlockToDoc{|FIELD of {gfd_name}|} _ _ = abort "error in docBlockToDoc{|FIELD|}\n"
docBlockToDoc{|RECORD|} fx (Left [s]) = case parseDocBlock s of
Right (db, ws) -> case fx (Right db) of
Right (v, ws`) -> Right (RECORD v, ws ++ ws`)
......@@ -147,6 +152,7 @@ docBlockToDoc{|EITHER|} fl fr doc = case fl doc of
docBlockToDoc{|OBJECT|} fx doc = appFst OBJECT <$> fx doc
docBlockToDoc{|MultiLineString|} (Left [s]) = Right (MultiLine $ trimMultiLine $ split "\n" s, [])
docBlockToDoc{|MultiLineString|} _ = abort "error in docBlockToDoc{|MultiLineString|}\n"
docBlockToDoc{|ParamDoc|} (Left [s]) = case findName (fromString s) of
Just (name,rest) -> Right (
......@@ -162,11 +168,13 @@ where
| not (isEmpty name) && not (isEmpty cs) && hd cs == ':'
= Just (toString name, dropWhile isSpace (tl cs))
= Nothing
docBlockToDoc{|ParamDoc|} _ = abort "error in docBlockToDoc{|ParamDoc|}\n"
docBlockToDoc{|Type|} (Left []) = Left InternalNoDataError
docBlockToDoc{|Type|} (Left ss) = case [v \\ Just v <- map ('T'.parseType o fromString) ss] of
[] -> Left (UnknownError "no parsable type")
vs -> Right (last vs, [])
docBlockToDoc{|Type|} _ = abort "error in docBlockToDoc{|Type|}\n"
docBlockToDoc{|Property|} (Left [s]) = let [signature:property] = split "\n" s in
parseSignature signature >>= \(sig,ws1) ->
......@@ -199,18 +207,21 @@ where
parseProperty :: ![String] -> Either ParseError (!String, ![ParseWarning])
parseProperty ss = Right (trimMultiLine ss, [])
docBlockToDoc{|Property|} _ = abort "error in docBlockToDoc{|Property|}\n"
docBlockToDoc{|PropertyVarInstantiation|} (Left [s]) = case split "=" s of
[var:type:[]] -> case 'T'.parseType (fromString type) of
Just t -> Right (PropertyVarInstantiation (trim var, t), [])
Nothing -> Left (UnknownError "type could not be parsed")
_ -> Left (UnknownError "property var instantiation could not be parsed")
docBlockToDoc{|PropertyVarInstantiation|} _ = abort "error in docBlockToDoc{|PropertyVarInstantiation|}\n"
docBlockToDoc{|PropertyTestGenerator|} (Left [s]) = case 'T'.parseType (fromString sig) of
Just t -> Right (PropertyTestGenerator t (trimMultiLine imp), [])
Nothing -> Left (UnknownError "type could not be parsed")
where
[sig:imp] = split "\n" s
docBlockToDoc{|PropertyTestGenerator|} _ = abort "error in docBlockToDoc{|PropertyTestGenerator|}\n"
derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ConstructorDoc,
ClassDoc, TypeDoc
......@@ -225,31 +236,40 @@ printDoc d = join "\n * "
] +++
"\n */"
where
(Right fields`) = docToDocBlock{|*|} False d
fields` = case docToDocBlock{|*|} False d of
Right fs -> fs
_ -> abort "error in printDoc\n"
fields = filter ((<>) "description" o fst) fields`
desc = lookup "description" fields`
generic docToDocBlock a :: Bool a -> Either [String] DocBlock
docToDocBlock{|String|} True s = Left [s]
docToDocBlock{|String|} _ _ = abort "error in docToDocBlock{|String|}\n"
docToDocBlock{|[]|} fx True xs = Left [x \\ Left xs` <- map (fx True) xs, x <- xs`]
docToDocBlock{|[]|} _ _ _ = abort "error in docToDocBlock{|[]|}\n"
docToDocBlock{|Maybe|} fx True mb = case mb of
Nothing -> Left []
Just x -> fx True x
docToDocBlock{|PAIR|} fx fy False (PAIR x y) = Right (xs ++ ys)
where
(Right xs) = fx False x
(Right ys) = fy False y
docToDocBlock{|FIELD of d|} fx False (FIELD x) = Right [(name,x) \\ x <- xs]
docToDocBlock{|Maybe|} _ _ _ = abort "error in docToDocBlock{|Maybe|}\n"
docToDocBlock{|PAIR|} fx fy False (PAIR x y) = case fx False x of
Right xs -> case fy False y of
Right ys -> Right (xs ++ ys)
_ -> abort "error in docToDocBlock{|PAIR|}\n"
_ -> abort "error in docToDocBlock{|PAIR|}\n"
docToDocBlock{|PAIR|} _ _ _ _ = abort "error in docToDocBlock{|PAIR|}\n"
docToDocBlock{|FIELD of d|} fx False (FIELD x) = case fx True x of
Left xs -> Right [(name,x) \\ x <- xs]
_ -> abort "error in docToDocBlock{|FIELD|}\n"
where
(Left xs) = fx True x
name = {if (c=='_') '-' c \\ c <-: name`}
name`
| endsWith "ies" d.gfd_name = d.gfd_name % (0,size d.gfd_name-4) +++ "y"
| endsWith "s" d.gfd_name = d.gfd_name % (0,size d.gfd_name-2)
| otherwise = d.gfd_name
docToDocBlock{|FIELD|} _ _ _ = abort "error in docToDocBlock{|FIELD|}\n"
docToDocBlock{|RECORD|} fx False (RECORD x) = fx False x
docToDocBlock{|RECORD|} _ _ _ = abort "error in docToDocBlock{|RECORD|}\n"
docToDocBlock{|ParamDoc|} True pd = case pd.ParamDoc.name of
Nothing -> case pd.ParamDoc.description of
......@@ -258,12 +278,18 @@ docToDocBlock{|ParamDoc|} True pd = case pd.ParamDoc.name of
Just n -> case pd.ParamDoc.description of
Nothing -> Left [n]
Just d -> Left [n +++ ": " +++ d]
docToDocBlock{|ParamDoc|} _ _ = abort "error in docToDocBlock{|ParamDoc|}\n"
docToDocBlock{|MultiLineString|} True (MultiLine s) = Left [s]
docToDocBlock{|MultiLineString|} _ _ = abort "error in docToDocBlock{|MultiLineString|}\n"
docToDocBlock{|Type|} True t = Left [toString t]
docToDocBlock{|Type|} _ _ = abort "error in docToDocBlock{|Type|}\n"
docToDocBlock{|Property|} True (ForAll name args impl) = Left
[name +++ ": A." +++ join "; " [a +++ " :: " <+ t \\ (a,t) <- args] +++ ":\n" +++ impl]
docToDocBlock{|Property|} _ _ = abort "error in docToDocBlock{|Property|}\n"
docToDocBlock{|PropertyVarInstantiation|} True (PropertyVarInstantiation (a,t)) = Left [a +++ " = " <+ t]
docToDocBlock{|PropertyVarInstantiation|} _ _ = abort "error in docToDocBlock{|PropertyVarInstantiation|}\n"
docToDocBlock{|PropertyTestGenerator|} True (PropertyTestGenerator t impl) = Left [t <+ "\n" +++ impl]
docToDocBlock{|PropertyTestGenerator|} _ _ = abort "error in docToDocBlock{|PropertyTestGenerator|}\n"
derive docToDocBlock ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc,
ConstructorDoc, TypeDoc
......@@ -302,6 +328,8 @@ where
parseFs :: ![Char] ![Char] !DocBlock -> Either ParseError (!DocBlock, ![ParseWarning])
parseFs field val d = Right ([(toString field,toString (rtrim val)):d], [])
parseFields _
= abort "error in parseDocBlock\n"
prepareString :: (String -> Either ParseError [[Char]])
prepareString = checkAsterisks o map trim o break '\n' o fromString
......@@ -340,6 +368,7 @@ where
toString (MissingAsterisk l) = "Doc error: missing leading asterisk in '" +++ l +++ "'"
toString (MissingField f) = "Doc error: required field '" +++ f +++ "' was missing"
toString (UnknownError e) = "Doc error: " +++ e
toString InternalNoDataError = "Doc error: internal parsing error"
traceParseWarnings :: ![ParseWarning] !a -> a
traceParseWarnings [] x = x
......
......@@ -3,6 +3,7 @@ implementation module Clean.Types
from StdOverloaded import class ==(..), class length(..)
from StdClass import class Eq
import StdList
import StdMisc
import StdTuple
from StdString import instance == {#Char}
import StdBool
......@@ -45,6 +46,7 @@ where
name :: !Type -> TypeVar
name (Cons v _) = v
name (Var v) = v
name _ = abort "error in allVars\n"
allUniversalVars :: !Type -> [TypeVar]
allUniversalVars (Forall vs t tc) = removeDup (flatten (map allVars vs) ++ allUniversalVars t)
......@@ -58,47 +60,60 @@ allUniversalVars (Arrow Nothing) = []
allUniversalVars (Strict t) = allUniversalVars t
isVar :: !Type -> Bool
isVar (Var _) = True; isVar _ = False
isVar t = t=:(Var _)
fromVar :: !Type -> TypeVar
fromVar (Var v) = v
fromVar t = case t of
Var v -> v
_ -> abort "error in fromVar\n"
fromVarLenient :: !Type -> TypeVar
fromVarLenient (Var v) = v
fromVarLenient (Cons v _) = v
fromVarLenient (Uniq t) = fromVarLenient t
fromVarLenient t = case t of
Var v -> v
Cons v _ -> v
Uniq t -> fromVarLenient t
Strict t -> fromVarLenient t
_ -> abort "missing case in fromVarLenient\n"
isCons :: !Type -> Bool
isCons (Cons _ _) = True; isCons _ = False
isCons t = t=:(Cons _ _)
isCons` :: TypeVar !Type -> Bool
isCons` v (Cons v` _) = v == v`; isCons` _ _ = False
isCons` v t = case t of
Cons v` _ -> v == v`
_ -> False
isVarOrCons` :: TypeVar !Type -> Bool
isVarOrCons` v (Var v`) = v == v`
isVarOrCons` v (Cons v` _) = v == v`
isVarOrCons` _ _ = False
isVarOrCons` v t = case t of
Var v` -> v == v`
Cons v` _ -> v == v`
_ -> False
isType :: !Type -> Bool
isType (Type _ _) = True; isType _ = False
isType t = t=:(Type _ _)
isFunc :: !Type -> Bool
isFunc (Func _ _ _) = True; isFunc _ = False
isFunc t = t=:(Func _ _ _)
isUniq :: !Type -> Bool
isUniq (Uniq _) = True; isUniq _ = False
isUniq t = t=:(Uniq _)
isForall :: !Type -> Bool
isForall (Forall _ _ _) = True; isForall _ = False
isForall t = t=:(Forall _ _ _)
fromForall :: !Type -> Type
fromForall (Forall _ t _) = t
fromForall t = case t of
Forall _ t _ -> t
_ -> abort "fromForall called on non-Forall\n"
isArrow :: !Type -> Bool
isArrow (Arrow _) = True; isArrow _ = False
isArrow t = t=:(Arrow _)
fromArrow :: !Type -> Maybe Type
fromArrow (Arrow t) = t
fromArrow t = case t of
Arrow t -> t
_ -> abort "fromArrow called on non-Arrow\n"
fromUnifyingAssignment :: !UnifyingAssignment -> TVAssignment
fromUnifyingAssignment (LeftToRight x) = x
......@@ -110,7 +125,9 @@ arity (Func is _ _) = length is
arity (Var _) = 0
arity (Cons _ ts) = length ts
arity (Strict t) = arity t
//TODO arity of Uniq / Forall / Arrow?
arity (Uniq _) = abort "what is the arity of Uniq?\n" // TODO
arity (Forall _ _ _) = abort "what is the arity of Forall?\n" // TODO
arity (Arrow _) = abort "what is the arity of Arrow?\n" // TODO
removeTypeContexts :: !Type -> Type
removeTypeContexts (Type s ts) = Type s $ map removeTypeContexts ts
......
......@@ -2,6 +2,7 @@ implementation module Clean.Types.Parse
from StdFunc import o
import StdList
import StdMisc
import StdString
import StdTuple
......@@ -46,8 +47,12 @@ from Text.Parsers.Simple.Core import :: Parser, :: Error,
instance == Token
where
== (TIdent a) (TIdent b) = a == b
== (TVar a) (TVar b) = a == b
== (TIdent a) b = case b of
TIdent b -> a == b
_ -> False
== (TVar a) b = case b of
TVar b -> a == b
_ -> False
== TArrow b = b=:TArrow
== TComma b = b=:TComma
== TStar b = b=:TStar
......@@ -140,10 +145,10 @@ where
<|> liftM Var var
ident :: Parser Token String
ident = (\(TIdent id)->id) <$> pSatisfy isTIdent
ident = (\tk -> case tk of TIdent id -> id; _ -> abort "error in type parser\n") <$> pSatisfy isTIdent
var :: Parser Token TypeVar
var = (\(TVar var)->var) <$> pSatisfy isTVar
var = (\tk -> case tk of TVar id -> id; _ -> abort "error in type parser\n") <$> pSatisfy isTVar
cons = var
unqvar = var
......
......@@ -3,6 +3,7 @@ implementation module Clean.Types.Util
import StdArray
import StdBool
from StdFunc import flip, id, o
import StdMisc
import StdOrdList
import StdString
import StdTuple
......@@ -95,15 +96,9 @@ where
instance print TypeDefRhs
where
print _ (TDRCons ext cs) = "\n\t= " -- makeADT ext cs
where
makeADT :: !Bool ![Constructor] -> String
makeADT exten [] = if exten " .." ""
makeADT False [c1:cs]
= concat (c1 -- "\n" --
concat [concat ("\t| " -- c -- "\n") \\ c <- cs])
makeADT True cs = concat (makeADT False cs -- "\t| ..")
print _ (TDRNewType c) = " =: " -- c
print _ (TDRCons ext cs) = "\n\t= " -- printADT ext cs
print _ (TDRMoreConses cs) = "\n\t| " -- printADT False cs
print _ (TDRNewType c) = " =: " -- c
print _ (TDRRecord _ exi fields) = " =" --
if (isEmpty exi) [] (" E." -- printersperse False " " exi -- ":") --
"\n\t" -- makeRecord exi fields
......@@ -124,6 +119,15 @@ where
print _ (TDRAbstract (Just rhs)) = " /*" -- rhs -- " */"
print _ (TDRAbstractSynonym t) = " (:== " -- t -- ")"
printADT :: !Bool ![Constructor] -> String
printADT True cs = case cs of
[] -> ".."
cs -> concat (printADT False cs -- "\t| ..")
printADT False cs = case cs of
[] -> ""
[c1:cs] -> concat (c1 -- "\n" --
concat [concat ("\t| " -- c -- "\n") \\ c <- cs])
typeConstructorName :: !Bool !Bool !String ![Type] -> [String]
typeConstructorName isInfix isArg t as
# isInfix = isInfix && not (isEmpty as)
......@@ -191,24 +195,28 @@ resolve_synonyms :: ('M'.Map String [TypeDef]) !Type -> ([TypeDef], Type)
resolve_synonyms tds (Type t ts)
# (syns, ts) = appFst (removeDupTypedefs o flatten) $ unzip $ map (resolve_synonyms tds) ts
= case candidates of
[] = (syns, Type t ts)
[] -> (syns, Type t ts)
[syn=:{td_args, td_rhs=TDRSynonym synt}:_]
# newargs = map ((+++) "__" o fromVar) td_args
# (Just t)
= assignAll [(fromVar a, Var n) \\ a <- td_args & n <- newargs] synt
>>= assignAll [(a,r) \\ a <- newargs & r <- ts]
| length td_args <> length ts
# (Type r rs) = t
# t = Type r $ rs ++ drop (length td_args) ts
= appFst ((++) [syn:syns]) $ resolve_synonyms tds t
= appFst ((++) [syn:syns]) $ resolve_synonyms tds t
# t = case assignAll [(fromVar a, Var n) \\ a <- td_args & n <- newargs] synt
>>= assignAll [(a,r) \\ a <- newargs & r <- ts] of
Just t -> t
_ -> abort "error in resolve_synonyms_Type\n"
| length td_args <> length ts -> case t of
Type r rs
# t = Type r $ rs ++ drop (length td_args) ts
-> appFst ((++) [syn:syns]) $ resolve_synonyms tds t
_ -> abort "error in resolve_synonyms_Type\n"
-> appFst ((++) [syn:syns]) $ resolve_synonyms tds t
_ -> abort "error in resolve_synonyms_Type\n"
where
candidates = [td \\ td=:{td_rhs=TDRSynonym syn} <- fromMaybe [] $ 'M'.get t tds
| length td.td_args <= tslen && (isType syn || length td.td_args == tslen)]
where tslen = length ts
resolve_synonyms tds (Func is r tc)
# (syns, [r:is]) = appFst (removeDupTypedefs o flatten) $ unzip $ map (resolve_synonyms tds) [r:is]
= (syns, Func is r tc)
= case appFst (removeDupTypedefs o flatten) $ unzip $ map (resolve_synonyms tds) [r:is] of
(syns, [r:is]) -> (syns, Func is r tc)
_ -> abort "error in resolve_synonyms_Func\n"
resolve_synonyms _ (Var v)
= ([], Var v)
resolve_synonyms tds (Cons v ts)
......
......@@ -103,16 +103,18 @@ where
isOctDigit c = '0' <= c && c <= '7'
parseType :: TarParser TarFileType
parseType = StateT $ \[c:cs] -> case c of
'0' = Ok (NormalFile, cs)
'1' = Ok (HardLink, cs)
'2' = Ok (SymLink, cs)
'3' = Ok (CharSpecial, cs)
'4' = Ok (BlockSpecial, cs)
'5' = Ok (Directory, cs)
'6' = Ok (FIFO, cs)
'7' = Ok (Contiguous, cs)
c = Error $ UnsupportedFileTypeId c
parseType = StateT $ \cs -> case cs of
[] -> Error UnexpectedEOS
[c:cs] -> case c of
'0' = Ok (NormalFile, cs)
'1' = Ok (HardLink, cs)
'2' = Ok (SymLink, cs)
'3' = Ok (CharSpecial, cs)
'4' = Ok (BlockSpecial, cs)
'5' = Ok (Directory, cs)
'6' = Ok (FIFO, cs)
'7' = Ok (Contiguous, cs)
c = Error $ UnsupportedFileTypeId c
skip :: Int -> TarParser ()
skip i = StateT $ \cs -> Ok ((), drop i cs)
......
......@@ -37,16 +37,20 @@ bimap{|{}|} bma = {map_to = mapArray bma.map_to, map_from = mapArray bma.map_fro
generic gLookupFMap key :: key (FMap value) -> FMap value
gLookupFMap{|Char|} key (FMChar xs) = lookupAssocList key FMEmpty xs
gLookupFMap{|Char|} key FMEmpty = FMEmpty
gLookupFMap{|Char|} _ _ = abort "error in gLookupFMap{|Char|}\n"
gLookupFMap{|Int|} key (FMInt xs) = lookupAssocList key FMEmpty xs
gLookupFMap{|Int|} key FMEmpty = FMEmpty
gLookupFMap{|Int|} key FMEmpty = FMEmpty
gLookupFMap{|Int|} _ _ = abort "error in gLookupFMap{|Int|}\n"
gLookupFMap{|Real|} key (FMReal xs) = lookupAssocList key FMEmpty xs
gLookupFMap{|Real|} key FMEmpty = FMEmpty
gLookupFMap{|Real|} key FMEmpty = FMEmpty
gLookupFMap{|Real|} _ _ = abort "error in gLookupFMap{|Real|}\n"
gLookupFMap{|Bool|} False (FMEither ls rs) = ls
gLookupFMap{|Bool|} True (FMEither ls rs) = rs
gLookupFMap{|Bool|} key FMEmpty = FMEmpty
gLookupFMap{|Bool|} False (FMEither ls rs) = ls
gLookupFMap{|Bool|} True (FMEither ls rs) = rs
gLookupFMap{|Bool|} key FMEmpty = FMEmpty
gLookupFMap{|Bool|} _ _ = abort "error in gLookupFMap{|Bool|}\n"
//gLookupFMap{|UNIT|} key (FMValue v) = (FMValue v)
//gLookupFMap{|UNIT|} key FMEmpty = FMEmpty
......@@ -54,9 +58,10 @@ gLookupFMap{|UNIT|} key fm = fm
gLookupFMap{|PAIR|} fx fy (PAIR kx ky) fm = fy ky (fx kx fm)
gLookupFMap{|EITHER|} fl fr (LEFT key) (FMEither ls rs) = fl key ls
gLookupFMap{|EITHER|} fl fr (LEFT key) (FMEither ls rs) = fl key ls
gLookupFMap{|EITHER|} fl fr (RIGHT key) (FMEither ls rs) = fr key rs
gLookupFMap{|EITHER|} fl fr key FMEmpty = FMEmpty
gLookupFMap{|EITHER|} fl fr key FMEmpty = FMEmpty
gLookupFMap{|EITHER|} _ _ _ _ = abort "error in gLookupFMap{|EITHER|}\n"
gLookupFMap{|CONS|} f (CONS key) fm = f key fm
gLookupFMap{|FIELD|} f (FIELD key) fm = f key fm
......@@ -86,23 +91,27 @@ gInsertFMap{|Char|} key (new_val, FMChar xs)
= (old_val, FMChar xs)
gInsertFMap{|Char|} key (new_val, FMEmpty)
= (FMEmpty, FMChar [(key, new_val)])
gInsertFMap{|Char|} _ _ = abort "error in gInsertFMap{|Char|}\n"
gInsertFMap{|Int|} key (new_val, FMInt xs)
# (old_val, xs) = updateAssocList key new_val FMEmpty xs
= (old_val, FMInt xs)
gInsertFMap{|Int|} key (new_val, FMEmpty)
= (FMEmpty, FMInt [(key, new_val)])
gInsertFMap{|Int|} _ _ = abort "error in gInsertFMap{|Int|}\n"
gInsertFMap{|Real|} key (new_val, FMReal xs)
# (old_val, xs) = updateAssocList key new_val FMEmpty xs
= (old_val, FMReal xs)
gInsertFMap{|Real|} key (new_val, FMEmpty)
= (FMEmpty, FMReal [(key, new_val)])
gInsertFMap{|Real|} _ _ = abort "error in gInsertFMap{|Real|}\n"
gInsertFMap{|Bool|} False (v, FMEither ls rs) = (ls, FMEither v rs)
gInsertFMap{|Bool|} False (v, FMEmpty) = (FMEmpty, FMEither v FMEmpty)
gInsertFMap{|Bool|} True (v, FMEither ls rs) = (rs, FMEither ls v)
gInsertFMap{|Bool|} True (v, FMEmpty) = (FMEmpty, FMEither FMEmpty v)
gInsertFMap{|Bool|} False (v, FMEither ls rs) = (ls, FMEither v rs)
gInsertFMap{|Bool|} False (v, FMEmpty) = (FMEmpty, FMEither v FMEmpty)
gInsertFMap{|Bool|} True (v, FMEither ls rs) = (rs, FMEither ls v)
gInsertFMap{|Bool|} True (v, FMEmpty) = (FMEmpty, FMEither FMEmpty v)
gInsertFMap{|Bool|} _ _ = abort "error in gInsertFMap{|Bool|}\n"
gInsertFMap{|UNIT|} key (x, y) = (y, x)
......@@ -124,6 +133,7 @@ gInsertFMap{|EITHER|} fl fr (RIGHT key) (v, FMEither ls rs)
gInsertFMap{|EITHER|} fl fr (RIGHT key) (v, FMEmpty)
# (old_val, new_rs) = fr key (v,FMEmpty)
= (FMEmpty, FMEither FMEmpty new_rs)
gInsertFMap{|EITHER|} _ _ _ _ = abort "error in gInsertFMap{|EITHER|}\n"
gInsertFMap{|CONS|} f (CONS key) x = f key x
gInsertFMap{|FIELD|} f (FIELD key) x = f key x
......
......@@ -37,6 +37,7 @@ instance Monad [] where
ret x = [x]
//(>>=) xs f = flatten (map f xs) // uniqueness typing makes it a problem because f is shared
(>>=) [x:xs] f = f x
(>>=) [] _ = []
//-----------------------
// state monad
......
implementation module Data.Encoding.RunLength
import StdOverloaded, StdList
import StdList
import StdMisc
import StdOverloaded
encodeInt :: ![Int] -> [Int]
encodeInt xs = reverse (rleInt` xs [])
......@@ -11,6 +13,7 @@ encodeInt xs = reverse (rleInt` xs [])
rleInt` [x:xs] [y : n : ys]
| x == y = rleInt` xs [y : n + 1 : ys]
| otherwise = rleInt` xs [x : 1 : y : n : ys]
rleInt` _ _ = abort "error in encodeInt\n"
decodeInt :: ![Int] -> [Int]
decodeInt xs = reverse (rldInt` xs [])
......@@ -19,6 +22,7 @@ decodeInt xs = reverse (rldInt` xs [])
rldInt` [] acc = acc
rldInt` [0 : x : xs] acc = rldInt` xs acc
rldInt` [n : x : xs] acc = rldInt` [n - 1 : x : xs] [x : acc]
rldInt` _ _ = abort "error in encodeInt\n"
encode :: ![a] -> [(Int, a)] | == a
encode xs = reverse (rle` xs [])
......
......@@ -26,5 +26,6 @@ derive gEq [], (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
eqArray f xs ys = size xs == size ys && eq 0 (size xs) xs ys
where
eq i n xs ys
| i == n = True
| i < n = f xs.[i] ys.[i] && eq (inc i