Commit 6e9d82b7 authored by Camil Staps's avatar Camil Staps 🚀

Merge branch 'remove-qualified-as' into 'master'

Remove qualified as

See merge request !212
parents 7ef2ae97 67e0dfe9
Pipeline #15400 passed with stage
in 1 minute and 41 seconds
......@@ -28,7 +28,7 @@ import Text.Language
import Text.Parsers.Simple.ParserCombinators
from Clean.Types import :: Type, :: TypeRestriction
import qualified Clean.Types.Parse as T
from Clean.Types.Parse import parseType
from Clean.Types.Util import instance toString Type
gDefault{|Maybe|} _ = Nothing
......@@ -171,7 +171,7 @@ where
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
docBlockToDoc{|Type|} (Left ss) = case [v \\ Just v <- map (parseType o fromString) ss] of
[] -> Left (UnknownError "no parsable type")
vs -> Right (last vs, [])
docBlockToDoc{|Type|} _ = abort "error in docBlockToDoc{|Type|}\n"
......@@ -201,7 +201,7 @@ where
skipSpaces = pMany (pSatisfy isSpace) *> pYield undef
pTypeWithColonOrSemicolon = (pMany (pSatisfy \c -> c <> ':' && c <> ';') <* pOneOf [':;'])
>>= \t -> case 'T'.parseType t of
>>= \t -> case parseType t of
Nothing -> pError "type could not be parsed"
Just t -> pure t
......@@ -210,13 +210,13 @@ where
docBlockToDoc{|Property|} _ = abort "error in docBlockToDoc{|Property|}\n"
docBlockToDoc{|PropertyVarInstantiation|} (Left [s]) = case split "=" s of
[var:type:[]] -> case 'T'.parseType (fromString type) of
[var:type:[]] -> case 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
docBlockToDoc{|PropertyTestGenerator|} (Left [s]) = case parseType (fromString sig) of
Just t -> Right (PropertyTestGenerator t (trimMultiLine imp), [])
Nothing -> Left (UnknownError "type could not be parsed")
where
......
......@@ -13,8 +13,7 @@ import StdTuple
import Control.Monad
import Data.Error
import Data.Functor
from Data.Map import :: Map
import qualified Data.Map as M
from Data.Map import :: Map(..), newMap, put, get
import Data.Maybe
import System.File
import System.FilePath
......@@ -226,17 +225,17 @@ instance < CommentIndex where < (CI a b c) (CI d e f) = (a,b,c) < (d,e,f)
putCC k v coll :== case commentIndex k of
Nothing -> coll
Just k -> 'M'.put k v coll
Just k -> put k v coll
emptyCollectedComments :: CollectedComments
emptyCollectedComments = 'M'.newMap
emptyCollectedComments = newMap
getComment :: !a !CollectedComments -> Maybe String | commentIndex a
getComment elem coll = (\cc -> cc.content) <$> (flip 'M'.get coll =<< commentIndex elem)
getComment elem coll = (\cc -> cc.content) <$> (flip get coll =<< commentIndex elem)
collectComments :: ![CleanComment] !ParsedModule -> CollectedComments
collectComments comments pm
# coll = 'M'.newMap
# coll = newMap
# (comments,coll) = case comments of
[] -> ([], coll)
[c:cs]
......
......@@ -10,7 +10,7 @@ definition module Clean.Types.CoclTransform
from Clean.Types import class toType, class toTypeVar, class toTypeDef,
class toTypeDefRhs, class toConstructor, class toRecordField,
class toTypeContext, class toMaybePriority
import qualified Clean.Types as T
import qualified Clean.Types
from Data.Maybe import :: Maybe
// Clean compiler frontend
......@@ -30,4 +30,4 @@ instance toConstructor 'syntax'.ParsedConstructor
instance toRecordField 'syntax'.ParsedSelector
instance toMaybePriority 'syntax'.Priority
pdType :: !'syntax'.ParsedDefinition -> Maybe 'T'.Type
pdType :: !'syntax'.ParsedDefinition -> Maybe 'Clean.Types'.Type
......@@ -15,7 +15,7 @@ from Data.Func import $
import Data.Functor
import Data.GenEq
import Data.List
import qualified Data.Map as M
from Data.Map import :: Map(..), get
import Data.Maybe
import Data.Tuple
from Text import class Text (concat), instance Text String
......@@ -191,7 +191,7 @@ propagate_uniqueness p (Strict t)
propagate_uniqueness p t
= t
resolve_synonyms :: ('M'.Map String [TypeDef]) !Type -> ([TypeDef], Type)
resolve_synonyms :: (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
......@@ -210,7 +210,7 @@ resolve_synonyms tds (Type t ts)
-> 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
candidates = [td \\ td=:{td_rhs=TDRSynonym syn} <- fromMaybe [] $ 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)
......@@ -276,7 +276,7 @@ reduceArities (Forall tvs t tc) = Forall tvs (reduceArities t) tc
reduceArities (Arrow mt) = Arrow (reduceArities <$> mt)
reduceArities (Strict t) = Strict $ reduceArities t
normalise_type :: (String -> Bool) !('M'.Map String [TypeDef]) !Type -> (!Type, ![TypeDef], ![TypeVar])
normalise_type :: (String -> Bool) !(Map String [TypeDef]) !Type -> (!Type, ![TypeDef], ![TypeVar])
normalise_type alwaysUnique tds t
# t = reduceArities t
# (syns,t) = resolve_synonyms tds t
......
implementation module Codec.Compression.Snappy
import StdClass
import StdInt
import StdMisc
import StdString
import StdEnv
import Data._Array
import System._Pointer
import System._Pointer, Data._Array
import Text
snappy_max_compressed_length :: !Int -> Int
......@@ -28,7 +24,7 @@ where
snappy_compress :: !.String -> .String
snappy_compress s
#! n = snappy_max_compressed_length (size s)
#! c = createArrayUnsafe (n+1)
#! c = unsafeCreateArray (n+1)
#! (r,len) = compress s (size s) c
| r <> 0 = abort ("Invalid return status of snappy_compress: " <+ r <+ "\n")
= {c \\ c <-: c & i <- [0..len-1]}
......@@ -41,7 +37,7 @@ where
snappy_uncompress :: !.String -> .String
snappy_uncompress s
#! n = snappy_uncompressed_length s
#! u = createArrayUnsafe (n+1)
#! u = unsafeCreateArray (n+1)
#! (r,len) = uncompress s (size s) u
| r <> 0 = abort ("Invalid return status of snappy_uncompress: " <+ r <+ "\n")
= {c \\ c <-: u & i <- [0..len-1]}
......
......@@ -2,8 +2,7 @@ implementation module Control.Applicative
import Control.Monad
import Data.Func, Data.Functor, System.IO, Data.List, Data.Maybe
from Data.Monoid import class Monoid, class Semigroup
import qualified Data.Monoid as DM
import Data.Monoid
from StdFunc import id, o, flip, const
class Applicative f | Functor f
......@@ -24,14 +23,14 @@ instance Functor (Const m) where
fmap _ (Const v) = Const v
instance Semigroup (Const a b) | Semigroup a where
mappend (Const a) (Const b) = Const ('DM'.mappend a b)
mappend (Const a) (Const b) = Const (mappend a b)
instance Monoid (Const a b) | Monoid a where
mempty = Const 'DM'.mempty
mempty = Const mempty
instance Applicative (Const m) | Monoid m where
pure _ = Const 'DM'.mempty
(<*>) (Const f) (Const v) = Const ('DM'.mappend f v)
pure _ = Const mempty
(<*>) (Const f) (Const v) = Const (mappend f v)
unwrapMonad :: !(WrappedMonad m a) -> m a
unwrapMonad (WrapMonad x) = x
......
implementation module Control.GenFMap
import StdGeneric, StdEnv, Data._Array, Control.GenMonad
import StdGeneric, StdEnv, Control.GenMonad
from Data.Maybe import :: Maybe(..)
derive bimap (,), []
......@@ -32,7 +32,6 @@ updateAssocList key value default_val [(k,v):xs]
= (old_val, [(k, v) : xs])
derive bimap FMap, Maybe
bimap{|{}|} bma = {map_to = mapArray bma.map_to, map_from = mapArray bma.map_from}
generic gLookupFMap key :: key (FMap value) -> FMap value
gLookupFMap{|Char|} key (FMChar xs) = lookupAssocList key FMEmpty xs
......
implementation module Control.GenMap
import StdClass, StdArray, StdInt, StdFunc
import StdGeneric, Data._Array
import StdGeneric
generic gMap a b :: .a -> .b
gMap{|c|} x = x
......@@ -12,7 +12,7 @@ gMap{|EITHER|} fl fr (RIGHT x) = RIGHT (fr x)
gMap{|CONS|} f (CONS x) = CONS (f x)
gMap{|FIELD|} f (FIELD x) = FIELD (f x)
gMap{|OBJECT|} f (OBJECT x) = OBJECT (f x)
gMap{|{}|} f xs = mapArray f xs
gMap{|{!}|} f xs = mapArray f xs
gMap{|{}|} f xs = {f x\\x<-:xs}
gMap{|{!}|} f xs = {f x\\x<-:xs}
derive gMap [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
implementation module Control.GenMapSt
import StdGeneric, Data._Array
derive bimap (,)
import StdGeneric, StdEnv, Data.Array, Data._Array
generic gMapLSt a b :: .a .st -> (.b, .st)
gMapLSt{|c|} x st = (x, st)
gMapLSt{|UNIT|} _ st = (UNIT, st)
gMapLSt{|PAIR|} fx fy (PAIR x y) st
# (x, st) = fx x st
# (y, st) = fy y st
= (PAIR x y, st)
# (x, st) = fx x st
# (y, st) = fy y st
= (PAIR x y, st)
gMapLSt{|EITHER|} fl fr x st = mapStEITHER fl fr x st
gMapLSt{|CONS|} f x st = mapStCONS f x st
gMapLSt{|FIELD|} f x st = mapStFIELD f x st
......@@ -23,11 +21,11 @@ derive gMapLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
generic gMapRSt a b :: .a .st -> (.b, .st)
gMapRSt{|c|} x st = (x, st)
gMapRSt{|UNIT|} _ st = (UNIT, st)
gMapRSt{|PAIR|} fx fy (PAIR x y) st
# (y, st) = fy y st
# (x, st) = fx x st
= (PAIR x y, st)
gMapRSt{|EITHER|} fx fy x st = mapStEITHER fx fy x st
gMapRSt{|PAIR|} fx fy (PAIR x y) st
# (y, st) = fy y st
# (x, st) = fx x st
= (PAIR x y, st)
gMapRSt{|EITHER|} fx fy x st = mapStEITHER fx fy x st
gMapRSt{|CONS|} f x st = mapStCONS f x st
gMapRSt{|FIELD|} f x st = mapStFIELD f x st
gMapRSt{|OBJECT|} f x st = mapStOBJECT f x st
......@@ -36,19 +34,46 @@ gMapRSt{|{!}|} f x st = mapArrayRSt f x st
derive gMapRSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
mapStEITHER fl fr (LEFT x) st
# (x, st) = fl x st
# (x, st) = fl x st
= (LEFT x, st)
mapStEITHER fl fr (RIGHT x) st
# (x, st) = fr x st
# (x, st) = fr x st
= (RIGHT x, st)
mapStCONS f (CONS x) st
# (x, st) = f x st
# (x, st) = f x st
= (CONS x, st)
mapStFIELD f (FIELD x) st
# (x, st) = f x st
= (FIELD x, st)
mapStOBJECT f (OBJECT x) st
# (x, st) = f x st
= (OBJECT x, st)
mapStFIELD f (FIELD x) st
# (x, st) = f x st
= (FIELD x, st)
mapStOBJECT f (OBJECT x) st
# (x, st) = f x st
= (OBJECT x, st)
mapArrayLSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, ys, st) = map f 0 size_xs xs (unsafeCreateArray size_xs) st
= (ys, st)
where
map f i n xs ys st
| i == n
= (xs, ys, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
#! (y, st) = f x st
#! ys = update ys i y
= map f (inc i) n xs ys st
mapArrayRSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, ys, st) = map f (size_xs - 1) xs (unsafeCreateArray size_xs) st
= (ys, st)
where
map f i xs ys st
| i < 0
= (xs, ys, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
#! (y, st) = f x st
#! ys = update ys i y
= map f (dec i) xs ys st
implementation module Control.GenReduce
import StdGeneric, Data._Array
import StdGeneric, StdEnv, Data.Array, Data._Array
// or crush
generic gReduce t :: (a a -> a) a t -> a
......@@ -42,3 +42,29 @@ derive gReduceLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
reduceEITHER fl fr (LEFT x) st = fl x st
reduceEITHER fl fr (RIGHT x) st = fr x st
reduceArrayLSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | Array c a, [v <= u]
reduceArrayLSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, st) = reduce f 0 size_xs xs st
= st
where
reduce f i n xs st
| i == n
= (xs, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
= reduce f (inc i) n xs (f x st)
reduceArrayRSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | Array c a, [v <= u]
reduceArrayRSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, st) = reduce f (dec size_xs) xs st
= st
where
reduce f i xs st
| i < 0
= (xs, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
= reduce f (dec i) xs (f x st)
......@@ -35,3 +35,5 @@ instance +++ (arr a) | Array arr a
instance Functor {}, {!}
instance Applicative {}, {!}
instance Monad {}, {!}
reduceArray :: ((.a -> u:(b -> b)) -> .(b -> .(c -> .a))) (.a -> u:(b -> b)) b .(d c) -> b | Array d c
......@@ -130,3 +130,13 @@ where
instance Monad {} where bind m k = foldrArr ((+++) o k) {} m
instance Monad {!} where bind m k = foldrArr ((+++) o k) {} m
reduceArray :: ((.a -> u:(b -> b)) -> .(b -> .(c -> .a))) (.a -> u:(b -> b)) b .(d c) -> b | Array d c
reduceArray f op e xs
= reduce f 0 (size xs) op e xs
where
reduce f i n op e xs
| i == n
= e
| otherwise
= op (f op e xs.[i]) (reduce f (inc i) n op e xs)
......@@ -3,7 +3,7 @@ implementation module Data.CircularStack
//import StdInt, StdOverloaded, StdArray, StdMisc, StdList
import StdInt, StdList, StdMisc
from Data.IntMap.Strict import :: IntMap
import qualified Data.IntMap.Strict as DIS
import qualified Data.IntMap.Strict
from Data.Maybe import :: Maybe (..)
newStack :: !Int -> CircularStack a
......@@ -11,13 +11,13 @@ newStack n = { CircularStack
| maxSize = n
, actualSize = 0
, nextIdx = 0
, stackData = 'DIS'.newMap
, stackData = 'Data.IntMap.Strict'.newMap
}
push :: !a !(CircularStack a) -> CircularStack a
push x stack
= { stack
& stackData = 'DIS'.put stack.nextIdx x stack.stackData
& stackData = 'Data.IntMap.Strict'.put stack.nextIdx x stack.stackData
, actualSize = if (stack.actualSize == stack.maxSize)
stack.actualSize
(stack.actualSize + 1)
......@@ -29,7 +29,7 @@ pop stack
| emptyStack stack = (Nothing, stack)
| otherwise
# topIdx = topElemIdx stack
= ( 'DIS'.get topIdx stack.stackData
= ( 'Data.IntMap.Strict'.get topIdx stack.stackData
, { stack
& nextIdx = topIdx
, actualSize = stack.actualSize - 1})
......@@ -37,7 +37,7 @@ pop stack
peek :: !(CircularStack a) -> Maybe a
peek stack
| emptyStack stack = Nothing
| otherwise = 'DIS'.get (topElemIdx stack) stack.stackData
| otherwise = 'Data.IntMap.Strict'.get (topElemIdx stack) stack.stackData
topElemIdx :: !(CircularStack a) -> Int
topElemIdx stack
......
......@@ -3,14 +3,13 @@ implementation module Data.Either
from StdEnv import flip, id, o, const
from StdMisc import abort
import Control.Applicative
import Control.Monad
import Control.Monad => qualified mapM
import Data.Monoid
import Data.Functor
import Data.Maybe
import Data.Monoid
from Data.Foldable import class Foldable(foldMap,foldl,foldr)
from Data.Traversable import class Traversable(traverse)
import qualified Data.Traversable as T
from Data.Traversable import class Traversable(traverse,mapM)
import Data.Bifunctor
import Data.GenEq
......@@ -64,7 +63,7 @@ where
traverse f (Right y) = Right <$> f y
sequenceA f = traverse id f
mapM f x = unwrapMonad (traverse (WrapMonad o f) x)
sequence x = 'T'.mapM id x
sequence x = mapM id x
instance Bifunctor Either
where
......
......@@ -7,7 +7,6 @@ from Control.Monad import class Monad(..), >>=
from Data.List import instance Semigroup [a], instance Monoid [a], instance Foldable []
import Data.Monoid
import Data.Maybe
import qualified StdList as SL
import StdClass
from StdOverloaded import class < (..)
from StdBool import not
......
implementation module Data.GenCompress
import StdGeneric, StdEnv, Data._Array
import StdGeneric, StdEnv
from Data.Maybe import :: Maybe(..)
import Data._Array
//--------------------------------------------------
// uncompressor monad
ret :: !.a !u:CompressSt -> (!Maybe .a,!u:CompressSt)
ret a st = (Just a, st)
(>>=) infixl 5
(>>=) infixl 5
(>>=) pa pb = bind pa pb
where
bind pa pb st
bind pa pb st
#! (ma, st) = pa st
= case ma of
Nothing -> (Nothing, st)
......@@ -35,7 +36,7 @@ compressBool bit {cs_pos = pos, cs_bits = bits}
#! int_pos = pos >> (IF_INT_64_OR_32 6 5)
#! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)
| s == int_pos
= abort "reallocate"
= abort "reallocate"
#! int = bits.[int_pos]
#! bit_mask = 1 << bit_pos
#! new_int = if bit (int bitor bit_mask) (int bitand (bitnot bit_mask))
......@@ -47,7 +48,7 @@ uncompressBool cs=:{cs_pos = pos, cs_bits = bits}
#! int_pos = pos >> (IF_INT_64_OR_32 6 5)
#! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)
| s == int_pos
= (Nothing, cs)
= (Nothing, cs)
#! int = bits.[int_pos]
#! bit_mask = 1 << bit_pos
#! bit = (bit_mask bitand int) <> 0
......@@ -61,7 +62,7 @@ where
| i == n
= id
| otherwise
= compress (inc i) n (int >> 1)
= compress (inc i) n (int >> 1)
o compressBool ((int bitand 1) == 1)
......@@ -77,14 +78,14 @@ where
= ret int
| otherwise
= uncompressBool
>>= \bit -> uncompress (inc i) n int
>>= \bit -> uncompress (inc i) n int
>>= \x -> ret ((if bit 1 0) + (x << 1))
uncompressInt :: (u:CompressSt -> (.(Maybe Int),v:CompressSt)), [u <= v]
uncompressInt = uncompressIntB (IF_INT_64_OR_32 64 32)
uncompressChar :: (u:CompressSt -> (.(Maybe Char),v:CompressSt)), [u <= v]
uncompressChar = uncompressIntB 8 >>= ret o toChar
uncompressChar = uncompressIntB 8 >>= ret o toChar
realToBinary32 :: !Real -> (!Int,!Int);
realToBinary32 _ = code {
......@@ -116,25 +117,25 @@ uncompressReal
= IF_INT_64_OR_32
(uncompressInt
>>= \i -> ret (binaryToReal64 i))
(uncompressInt
>>= \i1 -> uncompressInt
(uncompressInt
>>= \i1 -> uncompressInt
>>= \i2 -> ret (binaryToReal32 (i1,i2)))
compressArray :: (a -> u:(v:CompressSt -> w:CompressSt)) !.(b a) -> x:(*CompressSt -> y:CompressSt) | Array b a, [x <= u,w <= v,w <= y]
compressArray f xs
compressArray f xs
= foldSt f [x \\ x <-: xs] o compressInt (size xs)
foldSt f [] = id
foldSt f [x:xs] = foldSt f xs o f x
uncompressArray :: (u:CompressSt -> ((Maybe v:a),w:CompressSt)) -> .(x:CompressSt -> ((Maybe y:(b v:a)),z:CompressSt)) | Array b a, [x w <= u,y <= v,x w <= z]
uncompressArray f
= uncompressInt >>= \s -> uncompress_array 0 s (createArrayUnsafe s)
where
uncompressArray f
= uncompressInt >>= \s -> uncompress_array 0 s (unsafeCreateArray s)
where
uncompress_array i s arr
| i == s
= ret arr
= f >>= \x -> uncompress_array (inc i) s {arr & [i] = x}
= f >>= \x -> uncompress_array (inc i) s {arr & [i] = x}
compressList :: (a *CompressSt -> *CompressSt) ![a] -> *CompressSt -> *CompressSt
compressList c xs = compressArray c (list_to_arr xs)
......@@ -146,13 +147,13 @@ where
uncompressList xs = uncompressArray xs >>= ret o arr_to_list
where