diff options
| -rw-r--r-- | src/Data/Array/Mixed/Shape.hs | 49 |
1 files changed, 29 insertions, 20 deletions
diff --git a/src/Data/Array/Mixed/Shape.hs b/src/Data/Array/Mixed/Shape.hs index 4343574..e46105d 100644 --- a/src/Data/Array/Mixed/Shape.hs +++ b/src/Data/Array/Mixed/Shape.hs @@ -92,6 +92,16 @@ listxShow f l = showString "[" . go "" l . showString "]" go _ ZX = id go prefix (x ::% xs) = showString prefix . f x . go "," xs +listxFromList :: StaticShX sh -> [i] -> ListX sh (Const i) +listxFromList topssh topl = go topssh topl + where + go :: StaticShX sh' -> [i] -> ListX sh' (Const i) + go ZKX [] = ZX + go (_ :!% sh) (i : is) = Const i ::% go sh is + go _ _ = error $ "IsList(ListX): Mismatched list length (type says " + ++ show (ssxLength topssh) ++ ", list has length " + ++ show (length topl) ++ ")" + listxToList :: ListX sh' (Const i) -> [i] listxToList ZX = [] listxToList (Const i ::% is) = i : listxToList is @@ -150,6 +160,9 @@ ixxZero' :: IShX sh -> IIxX sh ixxZero' ZSX = ZIX ixxZero' (_ :$% sh) = 0 :.% ixxZero' sh +ixxFromList :: forall sh i. StaticShX sh -> [i] -> IxX sh i +ixxFromList = coerce (listxFromList @_ @i) + ixxTail :: IxX (n : sh) i -> IxX sh i ixxTail (IxX list) = IxX (listxTail list) @@ -274,6 +287,20 @@ shxSize :: IShX sh -> Int shxSize ZSX = 1 shxSize (n :$% sh) = fromSMayNat' n * shxSize sh +shxFromList :: StaticShX sh -> [Int] -> ShX sh Int +shxFromList topssh topl = go topssh topl + where + go :: StaticShX sh' -> [Int] -> ShX sh' Int + go ZKX [] = ZSX + go (SKnown sn :!% sh) (i : is) + | i == fromSNat' sn = SKnown sn :$% go sh is + | otherwise = error $ "shxFromList: Value does not match typing (type says " + ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")" + go (SUnknown () :!% sh) (i : is) = SUnknown i :$% go sh is + go _ _ = error $ "shxFromList: Mismatched list length (type says " + ++ show (ssxLength topssh) ++ ", list has length " + ++ show (length topl) ++ ")" + shxToList :: IShX sh -> [Int] shxToList ZSX = [] shxToList (smn :$% sh) = fromSMayNat' smn : shxToList sh @@ -440,14 +467,7 @@ shxFlatten = go (SNat @1) -- | Very untyped: only length is checked (at runtime). instance KnownShX sh => IsList (ListX sh (Const i)) where type Item (ListX sh (Const i)) = i - fromList topl = go (knownShX @sh) topl - where - go :: StaticShX sh' -> [i] -> ListX sh' (Const i) - go ZKX [] = ZX - go (_ :!% sh) (i : is) = Const i ::% go sh is - go _ _ = error $ "IsList(ListX): Mismatched list length (type says " - ++ show (ssxLength (knownShX @sh)) ++ ", list has length " - ++ show (length topl) ++ ")" + fromList = listxFromList (knownShX @sh) toList = listxToList -- | Very untyped: only length is checked (at runtime), index bounds are __not checked__. @@ -459,16 +479,5 @@ instance KnownShX sh => IsList (IxX sh i) where -- | Untyped: length and known dimensions are checked (at runtime). instance KnownShX sh => IsList (ShX sh Int) where type Item (ShX sh Int) = Int - fromList topl = ShX (go (knownShX @sh) topl) - where - go :: StaticShX sh' -> [Int] -> ListX sh' (SMayNat Int SNat) - go ZKX [] = ZX - go (SKnown sn :!% sh) (i : is) - | i == fromSNat' sn = SKnown sn ::% go sh is - | otherwise = error $ "IsList(ShX): Value does not match typing (type says " - ++ show (fromSNat' sn) ++ ", list contains " ++ show i ++ ")" - go (SUnknown () :!% sh) (i : is) = SUnknown i ::% go sh is - go _ _ = error $ "IsList(ShX): Mismatched list length (type says " - ++ show (ssxLength (knownShX @sh)) ++ ", list has length " - ++ show (length topl) ++ ")" + fromList = shxFromList (knownShX @sh) toList = shxToList |