packages feed

huihua (empty) → 0.1.0.1

raw patch · 10 files changed

+2879/−0 lines, 10 filesdep +adjunctionsdep +basedep +bytestring

Dependencies added: adjunctions, base, bytestring, containers, deepseq, distributive, doctest-parallel, flatparse, harpie, huihua, markup-parse, prettyprinter, random, string-interpolate, text, these, vector

Files

+ huihua.cabal view
@@ -0,0 +1,95 @@+cabal-version: 3.4+name: huihua+version: 0.1.0.1+license: BSD-3-Clause+copyright: Copywrite, Tony Day, 2023-+category: project+author: Tony Day+maintainer: tonyday567@gmail.com+homepage: https://github.com/tonyday567/huihua#readme+bug-reports: https://github.com/tonyday567/huihua/issues+synopsis: uiua port+description: A Haskell uiua library for uiua.org.+build-type: Simple+tested-with:+  ghc ==9.6.7+  ghc ==9.8.4+  ghc ==9.10.2+  ghc ==9.12.2++source-repository head+  type: git+  location: https://github.com/tonyday567/huihua++common ghc-options-stanza+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints++common ghc2024-additions+  default-extensions:+    DataKinds+    DerivingStrategies+    DisambiguateRecordFields+    ExplicitNamespaces+    GADTs+    LambdaCase+    MonoLocalBinds+    RoleAnnotations++common ghc2024-stanza+  if impl(ghc >=9.10)+    default-language:+      GHC2024+  else+    import: ghc2024-additions+    default-language:+      GHC2021++library+  import: ghc-options-stanza+  import: ghc2024-stanza+  hs-source-dirs: src+  build-depends:+    adjunctions >=4.0 && <5,+    base >=4.14 && <5,+    bytestring >=0.11.3 && <0.13,+    containers >=0.6 && <0.9,+    deepseq >=1.4.4 && <1.6,+    distributive >=0.4 && <0.7,+    flatparse >=0.3.5 && <0.6,+    harpie >=0.1 && <0.2,+    markup-parse >=0.1.1 && <0.3,+    prettyprinter >=1.7 && <1.8,+    random >=1.2 && <1.4,+    string-interpolate >=0.3 && <0.4,+    text >=2.0 && <2.2,+    these >=1.1 && <1.3,+    vector >=0.12.3 && <0.14,++  exposed-modules:+    Huihua.Array+    Huihua.ArrayU+    Huihua.Examples+    Huihua.Glyphs+    Huihua.Parse+    Huihua.Parse.FlatParse+    Huihua.Stack+    Huihua.Warning++test-suite doctests+  import: ghc2024-stanza+  main-is: doctests.hs+  hs-source-dirs: test+  build-depends:+    base >=4.14 && <5,+    doctest-parallel >=0.3 && <0.5,+    huihua,++  ghc-options: -threaded+  type: exitcode-stdio-1.0
+ src/Huihua/Array.hs view
@@ -0,0 +1,487 @@+-- | uiua API for harry+module Huihua.Array+  ( dyadicPervasive,+    reduceU,+    reduce1U,++    -- * Mirror of uiua API+    not,+    sign,+    negate',+    absolute,+    sqrt,+    sin,+    floor,+    ceiling,+    round,+    sig,+    add,+    subtract,+    multiply,+    divide,+    equals,+    notequals,+    lessThan,+    lessOrEqual,+    greaterThan,+    greaterOrEqual,+    modulus,+    modD,+    power,+    logarithm,+    minimum,+    maximum,+    atangent,+    length,+    shape,+    range,+    first,+    reverse,+    deshape,+    fix,+    bits',+    bits,+    transpose,+    rise,+    fall,+    where',+    classifyScan,+    classify,+    deduplicateScan,+    deduplicate,+    uniqueScan,+    unique,+    member,+    indexOf,+    couple,+    match,+    pick,+    rotate,+    join,+    select,+    take,+    drop,+    reshape,+    rerank,+    windows,+    keep,+    find,+    mask,+    equalsR,+    notEqualsR,+    lessThanR,+    lessOrEqualR,+    greaterThanR,+    greaterOrEqualR,+    addR,+    subtractR,+    multiplyR,+    divideR,+    minimumR,+    maximumR,+    modulusR,+    powerR,+    logarithmR,+    (¬),+  )+where++import Data.Bits hiding (rotate)+import Data.Bool hiding (not)+import Data.Foldable hiding (find, length, maximum, minimum)+import Data.Function hiding (fix)+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Ord+import Data.Set qualified as Set+import Data.Vector qualified as V+import Harpie.Array (Array (..))+import Harpie.Array qualified as D+import Harpie.Shape qualified as S+import Huihua.Warning+import Prelude hiding (ceiling, drop, floor, length, maximum, minimum, not, reverse, round, sin, sqrt, subtract, take)+import Prelude qualified as P++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Huihua.Array as A+-- >>> import Harpie.Array as D+-- >>> import Prettyprinter++-- | Dyadic pervasive+dyadicPervasive :: (b -> a -> c) -> Array a -> Array b -> Either HuihuaWarning (Array c)+dyadicPervasive op a b+  | D.shape a `List.isPrefixOf` D.shape b = Right (D.transmit (D.zipWith (flip op)) a b)+  | D.shape b `List.isPrefixOf` D.shape a = Right (D.transmit (D.zipWith op) b a)+  | otherwise = Left SizeMismatch++-- | Apply a binary boolean function, right-to-left+dyadicPervasiveBool :: (b -> a -> Bool) -> Array a -> Array b -> Either HuihuaWarning (Array Int)+dyadicPervasiveBool f = dyadicPervasive (\x x' -> sig (f x x'))++-- | https://www.uiua.org/docs/reduce+reduceU :: (a -> b -> b) -> b -> Array a -> Array b+reduceU f a0 a = D.reduces (S.exceptDims [0] (D.shape a)) (foldl' (flip f) a0) a++-- | Version for no identity functions+reduce1U :: (a -> a -> a) -> Array a -> Either HuihuaWarning (Array a)+reduce1U f a+  | null a = Left NoIdentity+  | D.length a == 1 = Right (D.select 0 0 a)+  | otherwise =+      let (x D.:> xs) = a+       in Right (D.zipWith (foldl' (flip f)) x (D.extracts (S.exceptDims [0] (D.shape xs)) xs))++-- * uiua api++not :: (Num a) => Array a -> Array a+not = fmap (1 -)++(¬) :: (Num a) => Array a -> Array a+(¬) = not++sign :: (Num a) => Array a -> Array a+sign = fmap signum++negate' :: (Num a) => Array a -> Array a+negate' = fmap negate++absolute :: (Num a) => Array a -> Array a+absolute = fmap abs++sqrt :: (Floating a) => Array a -> Array a+sqrt = fmap P.sqrt++sin :: (Floating a) => Array a -> Array a+sin = fmap P.sin++floor :: (RealFrac a) => Array a -> Array Int+floor = fmap P.floor++ceiling :: (RealFrac a) => Array a -> Array Int+ceiling = fmap P.ceiling++round :: (RealFrac a) => Array a -> Array Int+round = fmap P.round++sig :: Bool -> Int+sig = bool 0 1++add :: (Num a) => Array a -> Array a -> Either HuihuaWarning (Array a)+add = dyadicPervasive (+)++subtract :: (Num a) => Array a -> Array a -> Either HuihuaWarning (Array a)+subtract = dyadicPervasive (-)++multiply :: (Num a) => Array a -> Array a -> Either HuihuaWarning (Array a)+multiply = dyadicPervasive (*)++divide :: (Fractional a) => Array a -> Array a -> Either HuihuaWarning (Array a)+divide = dyadicPervasive (/)++equals :: (Eq a) => Array a -> Array a -> Either HuihuaWarning (Array Int)+equals = dyadicPervasiveBool (==)++notequals :: (Eq a) => Array a -> Array a -> Either HuihuaWarning (Array Int)+notequals = dyadicPervasiveBool (/=)++lessThan :: (Ord a) => Array a -> Array a -> Either HuihuaWarning (Array Int)+lessThan = dyadicPervasiveBool (<)++lessOrEqual :: (Ord a) => Array a -> Array a -> Either HuihuaWarning (Array Int)+lessOrEqual = dyadicPervasiveBool (<=)++greaterThan :: (Ord a) => Array a -> Array a -> Either HuihuaWarning (Array Int)+greaterThan = dyadicPervasiveBool (>)++greaterOrEqual :: (Ord a) => Array a -> Array a -> Either HuihuaWarning (Array Int)+greaterOrEqual = dyadicPervasiveBool (>=)++modulus :: Array Double -> Array Double -> Either HuihuaWarning (Array Double)+modulus = dyadicPervasive modD++-- | `mod` for doubles.+-- >>> modD 7.5 5+-- 2.5+modD :: Double -> Double -> Double+modD n d+  | d == (1 / 0) = n+  | d == 0 = 0 / 0+  | otherwise = n - d * fromIntegral (P.floor (n / d) :: Int)++power :: (Floating a) => Array a -> Array a -> Either HuihuaWarning (Array a)+power = dyadicPervasive (**)++logarithm :: (Floating a) => Array a -> Array a -> Either HuihuaWarning (Array a)+logarithm = dyadicPervasive (\x x' -> logBase x' x)++minimum :: (Ord a) => Array a -> Array a -> Either HuihuaWarning (Array a)+minimum = dyadicPervasive P.min++maximum :: (Ord a) => Array a -> Array a -> Either HuihuaWarning (Array a)+maximum = dyadicPervasive P.max++atangent :: (RealFloat a) => Array a -> Array a -> Either HuihuaWarning (Array a)+atangent = dyadicPervasive (flip atan2)++length :: Array a -> Array Int+length = D.toScalar . D.length++range :: Array Int -> Array Int+range a+  | D.rank a == 0 = bool (D.range [D.fromScalar a]) (fmap (negate 1 -) $ D.range [abs $ D.fromScalar a]) (D.fromScalar a < 0)+  | otherwise = D.join $ D.tabulate (D.arrayAs a') (\s -> D.asArray $ D.zipWith (\ab si -> bool ab (negate 1 - ab) (si < 0)) (D.asArray s) s')+  where+    a' = fmap abs a+    s' = fmap signum a++shape :: Array a -> Array Int+shape = D.asArray . D.shape++first :: Array a -> Array a+first = D.select 0 0++reverse :: Array a -> Array a+reverse a = D.reverses [0] a++deshape :: Array a -> Array a+deshape a = D.reshape [product (D.shape a)] a++fix :: Array a -> Array a+fix a = D.elongate 0 a++bits' :: Int -> Array Int+bits' x =+  bool id (fmap negate) (x < 0) $+    [0 ..] & P.take (finiteBitSize x' - countLeadingZeros x') & fmap (sig . testBit x') & D.asArray+  where+    x' = abs x++bits :: Array Int -> Array Int+bits a = D.join bs'+  where+    bs = fmap bits' a+    m = P.maximum (fmap D.length bs)+    bs' = fmap (D.pad 0 [m]) bs++-- | Rotate the axes by 1+transpose :: Array a -> Array a+transpose a = D.reorder (S.rotate 1 [0 .. D.rank a - 1]) a++rise :: (Ord a) => Array a -> Array Int+rise a = D.orders [0] $ D.extracts [0] a++fall :: (Ord a) => Array a -> Array Int+fall a = D.ordersBy [0] (fmap Down) $ D.extracts [0] a++where' :: Array Int -> Array Int+where' a = D.join $ D.asArray $ fmap D.asArray $ fold $ D.zipWith replicate a (D.indices (D.shape a))++classifyScan :: (Ord a) => [a] -> [Int]+classifyScan [] = []+classifyScan (x : xs) =+  (\(f, _, _) -> f)+    <$> scanl+      ( \(s, c, m) k ->+          maybe+            (c, c + 1, Map.insert k (1 + s) m)+            (,c,m)+            (Map.lookup k m)+      )+      (0, 1, Map.singleton x (0 :: Int))+      xs++classify :: (Ord a) => Array a -> Array Int+classify a = (D.asArray . classifyScan . D.arrayAs) $ D.extracts [0] a++deduplicateScan :: (Ord a) => [a] -> [(Maybe a, Set.Set a)]+deduplicateScan [] = []+deduplicateScan (x0 : xs) =+  scanl+    ( \(_, set) k ->+        bool+          (Just k, Set.insert k set)+          (Nothing, set)+          (Set.member k set)+    )+    (Just x0, Set.singleton x0)+    xs++deduplicate :: (Ord a) => Array a -> Array a+deduplicate a = D.joins [0] $ (D.asArray . mapMaybe fst . deduplicateScan . D.arrayAs) $ D.extracts [0] a++uniqueScan :: (Ord a) => [a] -> [(Int, Set.Set a)]+uniqueScan [] = []+uniqueScan (x0 : xs) =+  scanl+    ( \(_, set) k ->+        bool+          (1, Set.insert k set)+          (0, set)+          (Set.member k set)+    )+    (1, Set.singleton x0)+    xs++unique :: (Ord a) => Array a -> Array Int+unique a = (D.asArray . fmap fst . uniqueScan . D.arrayAs) (D.extracts [0] a)++member :: (Ord a) => Array a -> Array a -> Array Int+member i a+  | D.isScalar i = fmap (sig . Set.member (D.fromScalar i) . Set.fromList . toList) (D.extracts (S.exceptDims [D.rank a - 1] (D.shape a)) a)+  | otherwise = D.asArray (fmap sig ks)+  where+    spliti+      | D.rank i == 0 = D.singleton i+      | D.rank a - D.rank i == 1 = D.singleton i+      | otherwise = D.extracts (List.take (D.rank i - D.rank a + 1) [0 ..]) i+    aset = Set.fromList (toList (D.extracts [0] a))+    ks = (\x -> Set.member x aset) <$> spliti++indexOf :: (Eq a) => Array a -> Array a -> Array Int+indexOf i a+  | D.isScalar i = fmap (\x -> findI x (D.fromScalar i)) (D.extracts (S.exceptDims [D.rank a - 1] (D.shape a)) a)+  | D.rank a == 1 = fmap (findI a) i+  | otherwise = fmap (findI (D.extracts (S.exceptDims [D.rank a - 1] (D.shape a)) a)) (D.extracts (S.exceptDims [D.rank i - 1] (D.shape i)) i)+  where+    findI xs i' = fromMaybe (List.length xs) . List.elemIndex i' . toList $ xs++couple :: Array a -> Array a -> Array a+couple x y = D.couple 0 x y++match :: (Eq a) => Array a -> Array a -> Array Int+match a a' = D.toScalar (bool 0 1 (a == a'))++pick :: Array Int -> Array a -> Either HuihuaWarning (Array a)+pick i a+  | D.length (first i) > D.rank a = Left BadPick+  | otherwise = Right $ D.join $ fmap (\s -> D.rowWise D.indexes (D.arrayAs s) a) (D.extracts [0 .. D.rank i - 2] i)++rotate :: Array Int -> Array a -> Array a+rotate r a = D.rowWise (D.dimsWise D.rotate) (D.arrayAs r) a++-- | https://www.uiua.org/docs/join+join :: Array a -> Array a -> Either HuihuaWarning (Array a)+join a a'+  | P.drop 1 (D.shape a) == P.drop 1 (D.shape a') = Right $ D.concatenate 0 a a'+  | D.shape a == P.drop 1 (D.shape a') = Right $ D.prepend 0 a a'+  | P.drop 1 (D.shape a) == D.shape a' = Right $ D.append 0 a a'+  | D.shape a `List.isSuffixOf` D.shape a' = Right $ D.prepend 0 (D.repeat (List.drop 1 $ D.shape a') a) a'+  | D.shape a' `List.isSuffixOf` D.shape a = Right $ D.append 0 a (D.repeat (List.drop 1 $ D.shape a) a')+  | otherwise = Left SizeMismatch++-- | Select multiple rows from an array+select :: Array Int -> Array a -> Array a+select i a = D.joins [0 .. D.rank i - 1] $ (\x -> D.indexes [0] [x] a) <$> i++-- |+--+-- >>> pretty $ Huihua.Array.reshape (D.asArray [3,2]) (D.asArray [1..5::Int])+-- [[1,2],+--  [3,4],+--  [5,1]]+-- >>> pretty $ Huihua.Array.reshape (D.asArray [3,-1]) (D.asArray [1..8::Int])+-- [[1,2],+--  [3,4],+--  [5,6]]+reshape :: Array Int -> Array a -> Array a+reshape i a+  | D.rank i == 0 = D.repeat (D.fromScalar i : D.shape a) a+  | otherwise = D.array i' (V.take (product i') (V.concat (replicate (1 + product i' `div` V.length (D.asVector a)) (D.asVector a))))+  where+    iflat = D.arrayAs i+    hasNeg = any (< 0) iflat+    i' = bool iflat (fmap (\x -> bool x subDim (x < 0)) iflat) hasNeg+    subDim = D.size a `div` product (filter (>= 0) iflat)++rerank :: Array Int -> Array a -> Either HuihuaWarning (Array a)+rerank r a+  | P.not (D.isScalar r) = Left TypeMismatch+  | otherwise = Right (D.rerank r' a)+  where+    x = D.fromScalar r+    r' = bool (x + 1) (x + 1 + D.rank a) (x < 0)++take :: Array Int -> Array a -> Either HuihuaWarning (Array a)+take i a+  | D.rank i > 1 || D.length i > D.rank a = Left BadTake+  | otherwise = Right $ D.rowWise (D.dimsWise D.take) (D.arrayAs i) a++drop :: Array Int -> Array a -> Either HuihuaWarning (Array a)+drop i a+  | D.rank i > 1 || D.length i > D.rank a = Left BadTake+  | otherwise = Right $ D.rowWise (D.dimsWise D.drop) (D.arrayAs i) a++windows :: Array Int -> Array a -> Array a+windows ws a = D.windows ws' a+  where+    ws' = List.zipWith (\w s -> bool w (s - w + 1) (w < 0)) (D.arrayAs ws) (D.shape a)++keep :: Array Int -> Array a -> Array a+keep i a = D.join $ D.asArray $ fold $ D.zipWith replicate (D.cycle (List.take 1 $ D.shape a) i) (D.extracts [0] a)++find :: (Eq a) => Array a -> Array a -> Array Int+find i a = D.pad 0 (D.shape a :: [Int]) (fmap sig $ D.find i a)++mask :: (Eq a) => Array a -> Array a -> Array Int+mask i a = m+  where+    iexp = D.rerank (D.rank a) i+    found = fmap sig $ D.findNoOverlap iexp a+    accf = V.drop 1 . V.map snd . V.scanl' (\(acc, _) x -> bool (acc + 1, acc + 1) (acc, 0) (x == 0)) (0, 0)+    found' = D.unsafeModifyVector accf found+    found'' = D.pad 0 (D.shape a) found'+    start = (\s -> 1 - s) <$> D.shape iexp+    backchecks s = List.zip (List.zipWith (\s0 s' -> max 0 (s0 + s')) start s) (List.zipWith (\i' s' -> min i' (s' + 1)) (D.shape iexp) s)+    m = D.tabulate (D.shape a) (\s -> sum (D.rowWise (D.dimsWise (\d (o, l) -> D.slice d o l)) (backchecks s) found''))++-- * reducing operators++reduceBool :: (Num b) => (a -> a -> Bool) -> Array a -> Array b+reduceBool f a = fmap (bool 0 1 . or) (D.reduces (S.exceptDims [0] (D.shape a)) (D.diffs [0] [1] (D.zipWith f)) a)++equalsR :: (Eq a) => Array a -> Array Int+equalsR = reduceBool (==)++notEqualsR :: (Eq a) => Array a -> Array Int+notEqualsR = reduceBool (/=)++lessThanR :: (Ord a) => Array a -> Array Int+lessThanR = reduceBool (<)++lessOrEqualR :: (Ord a) => Array a -> Array Int+lessOrEqualR = reduceBool (<=)++greaterThanR :: (Ord a) => Array a -> Array Int+greaterThanR = reduceBool (>)++greaterOrEqualR :: (Ord a) => Array a -> Array Int+greaterOrEqualR = reduceBool (>=)++addR :: (Num a) => Array a -> Array a+addR = reduceU (+) 0++subtractR :: (Num a) => Array a -> Array a+subtractR = reduceU (-) 0++divideR :: (Fractional a) => Array a -> Array a+divideR = reduceU (/) 1++multiplyR :: (Num a) => Array a -> Array a+multiplyR = reduceU (*) 1++minimumR :: (Ord a, Fractional a) => Array a -> Array a+minimumR = reduceU min (1 / 0)++maximumR :: (Ord a, Fractional a) => Array a -> Array a+maximumR = reduceU max (-(1 / 0))++modulusR :: Array Double -> Array Double+modulusR = reduceU modD (1 / 0)++powerR :: (Floating a) => Array a -> Array a+powerR = reduceU (**) 1++logarithmR :: (Floating a) => Array a -> Either HuihuaWarning (Array a)+logarithmR = reduce1U (flip logBase)
+ src/Huihua/ArrayU.hs view
@@ -0,0 +1,929 @@+-- | Compatability layer between Harpie..Array and uiua arrays.+--+-- The main purpose is to change types from Double to Int and back as necessary. (all uiua arrays are doubles).+module Huihua.ArrayU+  ( -- $usage+    ArrayU (..),+    arrayi,+    arrayi',+    arrayi_,+    Res,+    isInt,+    asInt,+    showU,++    -- * uiua API+    duplicate,+    pop,+    identity,+    not,+    sign,+    negate',+    absoluteValue,+    sqrt,+    sine,+    floor,+    ceiling,+    round,+    length,+    shape,+    range,+    first,+    reverse,+    deshape,+    fix,+    bits,+    transpose,+    rise,+    fall,+    where',+    classify,+    deduplicate,+    unique,++    -- * dyadics+    equals,+    notequals,+    lessThan,+    lessOrEqual,+    greaterThan,+    greaterOrEqual,+    add,+    subtract,+    multiply,+    divide,+    modulus,+    power,+    logarithm,+    minimum,+    maximum,+    atangent,+    match,+    couple,+    join,+    select,+    pick,+    reshape,+    rerank,+    take,+    drop,+    rotate,+    windows,+    keep,+    find,+    mask,+    member,+    indexOf,++    -- * reductions+    equalsR,+    notEqualsR,+    lessThanR,+    lessOrEqualR,+    greaterThanR,+    greaterOrEqualR,+    addR,+    subtractR,+    multiplyR,+    divideR,+    modulusR,+    powerR,+    logarithmR,+    minimumR,+    maximumR,++    -- * testing only+    ptree,+    unfoldF,+  )+where++import Data.Bool (bool)+import Data.Either+import Data.Function ((&))+import Data.List qualified as List+import Data.Maybe+import Data.Text (Text, pack, unpack)+import Data.Text qualified as Text+import Data.Tree qualified as Tree+import GHC.Generics+import Harpie.Array (Array (..))+import Harpie.Array qualified as D+import Huihua.Array qualified as A+import Huihua.Warning+import Prettyprinter hiding (equals)+import Prelude hiding (ceiling, drop, floor, length, maximum, minimum, not, reverse, round, sin, sqrt, subtract, take)+import Prelude qualified as P++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XQuasiQuotes+-- >>> import Data.String.Interpolate+-- >>> import Huihua.Array as A+-- >>> import Harpie.Array as D+-- >>> import Prettyprinter+-- >>> import Huihua.Parse++-- | A uiua array which is always an Array Double underneath.+--+-- >>> x = D.array [2,2] [2, 2.222,200.001,200.01] :: Array Double+-- >>> pretty (ArrayU x)+-- ╭─+-- ╷       2  2.222+--   200.001 200.01+--                  ╯+newtype ArrayU = ArrayU {arrayd :: Array Double} deriving (Eq, Show, Generic)++instance Pretty ArrayU where+  pretty (ArrayU x) = case D.rank x of+    0 -> pretty $ showU (D.fromScalar x)+    1 -> pretty "[" <> hsep (fmap (pretty . showU) (D.arrayAs x)) <> pretty "]"+    _ -> final+    where+      t = ptree (fmap showU x)+      maxp = D.reduces [1] (P.maximum . fmap Text.length) (D.join $ D.asArray $ rights t)+      s = fmap (fmap (D.zipWith (\m a -> lpad' ' ' m a) maxp)) t+      sdoc = mconcat $ fmap (either (\n -> replicate (n - 1) mempty) (pure . hsep . fmap pretty . D.arrayAs)) s+      sdocMin = D.concatenate 0 (D.konst [max 0 (D.rank x - P.length sdoc - 1)] mempty) (D.asArray sdoc)+      rankPrefix = fmap pretty (D.pad " " [D.length sdocMin] (D.konst [D.rank x - 1] "╷"))+      deco = zipWith (<+>) (D.arrayAs rankPrefix) (D.arrayAs sdocMin)+      final = pretty "╭─" <> line <> vsep deco <> hang 1 (line <> pretty "╯")++showU :: Double -> Text+showU x = bool mempty (pack "¯") (x < 0) <> bool (pack $ show (abs x)) (pack $ show (asInt (abs x))) (isInt x)++lpad' :: Char -> Int -> Text -> Text+lpad' c maxl x = (pack $ replicate (maxl - P.length (unpack x)) c) <> x++unfoldF :: Either Int (Array a) -> (Maybe (Either Int (Array a)), [Either Int (Array a)])+unfoldF (Left n) = (Just (Left n), [])+unfoldF (Right a) = case D.rank a of+  1 -> (Just (Right a), [])+  _ -> (Nothing, List.intersperse (Left (D.rank a - 1)) (Right <$> D.arrayAs (D.extracts [0] a)))++ptree :: Array a -> [Either Int (Array a)]+ptree a = catMaybes $ Tree.flatten $ Tree.unfoldTree unfoldF (Right a)++arrayi :: ArrayU -> Array Int+arrayi (ArrayU a) = fmap asInt a++arrayi' :: ArrayU -> Either HuihuaWarning (Array Int)+arrayi' (ArrayU a) =+  bool+    (Left NotNat)+    (Right (fmap asInt a))+    (all isInt a)++isInt :: Double -> Bool+isInt x = x == fromIntegral (P.floor x :: Int)++asInt :: Double -> Int+asInt x = P.floor x++arrayi_ :: ArrayU -> Array Int+arrayi_ a = either (error . show) id (arrayi' a)++type Res = Either HuihuaWarning [ArrayU]++-- | .+--+-- >>> run ". [1 2 3]"+-- [1 2 3]+-- [1 2 3]+duplicate :: ArrayU -> Res+duplicate x = Right [x, x]++-- | ◌+--+-- >>> run [i|◌1 2|]+-- 2+pop :: ArrayU -> Res+pop _ = Right []++-- | ∘+--+-- >>> run [i|∘ 5|]+-- 5+identity :: ArrayU -> Res+identity x = Right [x]++-- | ¬+--+-- >>> run [i|¬0|]+-- 1+-- >>> run [i|¬[0 1 2 3]|]+-- [1 0 ¯1 ¯2]+not :: ArrayU -> Res+not (ArrayU a) = Right . pure . ArrayU . A.not $ a++-- | ±+--+-- >>> run [i|± 1|]+-- 1+sign :: ArrayU -> Res+sign (ArrayU a) = Right . pure . ArrayU . A.sign $ a++-- | ¯+--+-- negate is just about a reserved word in haskell eg -2 is parsed as negate 2.+--+-- >>> run [i|¯ 1|]+-- ¯1+negate' :: ArrayU -> Res+negate' (ArrayU a) = Right . pure . ArrayU . A.negate' $ a++-- | ⌵+--+-- >>> run [i|⌵ ¯1|]+-- 1+absoluteValue :: ArrayU -> Res+absoluteValue (ArrayU a) = Right . pure . ArrayU . A.absolute $ a++-- | √+--+-- >>> run [i|√4|]+-- 2+sqrt :: ArrayU -> Res+sqrt (ArrayU a) = Right . pure . ArrayU . A.sqrt $ a++-- | ∿+--+-- >>> run [i|∿ 1|]+-- 0.8414709848078965+sine :: ArrayU -> Res+sine (ArrayU a) = Right . pure . ArrayU . A.sin $ a++-- | ⌊+--+-- >>> run [i|⌊1.5|]+-- 1+floor :: ArrayU -> Res+floor (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.floor $ a++-- | ⌈+--+-- >>> run [i|⌈1.5|]+-- 2+ceiling :: ArrayU -> Res+ceiling (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.ceiling $ a++-- | ⁅+--+-- >>> run [i|⁅1.5|]+-- 2+round :: ArrayU -> Res+round (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.round $ a++-- | ⧻+--+-- >>> run [i|⧻[1 3 5]|]+-- 3+length :: ArrayU -> Res+length (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.length $ a++-- | △+--+-- >>> run [i|△1_2_3|]+-- [3]+-- >>> run [i|△1|]+-- []+-- >>> run [i|△[]|]+-- [0]+shape :: ArrayU -> Res+shape (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.shape $ a++-- | ⇡+--+-- >>> run [i|⇡5|]+-- [0 1 2 3 4]+-- >>> run [i|⇡2_3|]+-- ╭─+-- ╷ 0 0+-- ╷ 0 1+--   0 2+-- ...+--   1 0+--   1 1+--   1 2+--       ╯+-- >>> run [i|⇡[3]|]+-- ╭─+-- ╷ 0+--   1+--   2+--     ╯+range :: ArrayU -> Res+range (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.range $ fmap asInt a++-- | ⊢+--+-- >>> run [i|⊢1_2_3|]+-- 1+first :: ArrayU -> Res+first (ArrayU a) = Right . pure . ArrayU . A.first $ a++-- | ⇌+--+-- >>> run [i|⇌[1_2 3_4 5_6]|]+-- ╭─+-- ╷ 5 6+--   3 4+--   1 2+--       ╯+reverse :: ArrayU -> Res+reverse (ArrayU a) = Right . pure . ArrayU . A.reverse $ a++-- | ♭+--+-- >>> run [i|♭[1_2 3_4 5_6]|]+-- [1 2 3 4 5 6]+deshape :: ArrayU -> Res+deshape (ArrayU a) = Right . pure . ArrayU . A.deshape $ a++-- | ¤+--+-- >>> run [i|¤1_2]|]+-- ╭─+-- ╷ 1 2+--       ╯+fix :: ArrayU -> Res+fix (ArrayU a) = Right . pure . ArrayU . A.fix $ a++-- | ⋯+--+-- >>> run [i|⋯[1_2 3_4 5_6]|]+-- ╭─+-- ╷ 1 0 0+-- ╷ 0 1 0+-- ...+--   1 1 0+--   0 0 1+-- ...+--   1 0 1+--   0 1 1+--         ╯+bits :: ArrayU -> Res+bits (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.bits . fmap asInt $ a++-- | ⍉+--+-- >>> run [i|⍉[[1_2 3_4] [5_6 7_8]]|]+-- ╭─+-- ╷ 1 5+-- ╷ 2 6+-- ...+--   3 7+--   4 8+--       ╯+transpose :: ArrayU -> Res+transpose (ArrayU a) = Right . pure . ArrayU . A.transpose $ a++-- | ⍏+--+-- >>> run [i|⍏ 6_2_7_0_1_5|]+-- [3 4 1 5 0 2]+rise :: ArrayU -> Res+rise (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.rise $ a++-- | ⍖+--+-- >>> run [i|⍖ 6_2_7_0_1_5|]+-- [2 0 5 1 4 3]+fall :: ArrayU -> Res+fall (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.fall $ a++-- | ⊚+--+-- >>> run [i|⊚[1_0_0 0_1_1 0_2_0]|]+-- ╭─+-- ╷ 0 0+--   1 1+--   1 2+--   2 1+--   2 1+--       ╯+where' :: ArrayU -> Res+where' (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.where' . fmap asInt $ a++-- | ⊛+--+-- >>> run [i|⊛7_7_8_0_1_2_0|]+-- [0 0 1 2 3 4 2]+classify :: ArrayU -> Res+classify (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.classify $ a++-- | ◴+--+-- >>> run [i|◴ 7_7_8_0_1_2_0|]+-- [7 8 0 1 2]+deduplicate :: ArrayU -> Res+deduplicate (ArrayU a) = Right . pure . ArrayU . A.deduplicate $ a++-- | ◰+--+-- >>> run [i|◰ [3_2 1_4 3_2 5_6 1_4 7_8]|]+-- [1 1 0 1 0 1]+unique :: ArrayU -> Res+unique (ArrayU a) = Right . pure . ArrayU . fmap fromIntegral . A.unique $ a++-- | ∊+--+-- >>> run [i|∊ [1 2 3] [0 3 4 5 1]|]+-- [1 0 1]+member :: ArrayU -> ArrayU -> Res+member (ArrayU x) (ArrayU y) = Right . pure . ArrayU . fmap fromIntegral $ A.member x y++-- | ⊗+--+-- >>> run [i|⊗ 2 [1 2 3]|]+-- 1+indexOf :: ArrayU -> ArrayU -> Res+indexOf (ArrayU x) (ArrayU y) = Right . pure . ArrayU . fmap fromIntegral $ A.indexOf x y++-- * dyadic operators++-- | =+--+-- >>> run [i| =2 1|]+-- 0+-- >>> run [i| =2 [1 2 3]|]+-- [0 1 0]+-- >>> run [i| = [1 2 2] [1 2 3]|]+-- [1 1 0]+equals :: ArrayU -> ArrayU -> Res+equals (ArrayU x) (ArrayU y) = fmap (pure . ArrayU . fmap fromIntegral) $ A.equals x y++-- | ≠+--+-- >>> run [i| ≠2 1|]+-- 1+-- >>> run [i| ≠2 [1 2 3]|]+-- [1 0 1]+-- >>> run [i| ≠ [1 2 2] [1 2 3]|]+-- [0 0 1]+notequals :: ArrayU -> ArrayU -> Res+notequals (ArrayU x) (ArrayU y) = fmap (pure . ArrayU . fmap fromIntegral) $ A.notequals x y++-- | <+--+-- >>> run [i|<2 1|]+-- 1+-- >>> run [i|<2 [1 2 3]|]+-- [1 0 0]+-- >>> run [i|< [1 2 2] [1 2 3]|]+-- [0 0 0]+lessThan :: ArrayU -> ArrayU -> Res+lessThan (ArrayU x) (ArrayU y) = fmap (pure . ArrayU . fmap fromIntegral) $ A.lessThan x y++-- | ≤+--+-- >>> run [i|≤1 2|]+-- 0+-- >>> run [i|≤5 5|]+-- 1+lessOrEqual :: ArrayU -> ArrayU -> Res+lessOrEqual (ArrayU x) (ArrayU y) = fmap (pure . ArrayU . fmap fromIntegral) $ A.lessOrEqual x y++-- | >+--+-- >>> run [i| >1 2|]+-- 1+-- >>> run [i| >5 5|]+-- 0+greaterThan :: ArrayU -> ArrayU -> Res+greaterThan (ArrayU x) (ArrayU y) = fmap (pure . ArrayU . fmap fromIntegral) $ A.greaterThan x y++-- | ≥+--+-- >>> run [i| ≥1 2|]+-- 1+-- >>> run [i| ≥5 5|]+-- 1+greaterOrEqual :: ArrayU -> ArrayU -> Res+greaterOrEqual (ArrayU x) (ArrayU y) = fmap (pure . ArrayU . fmap fromIntegral) $ A.greaterOrEqual x y++-- | ++--+-- >>> run [i|+2 1|]+-- 3+-- >>> run [i|+2 [1 2 3]|]+-- [3 4 5]+-- >>> run [i|+ [1 2 2] [1 2 3]|]+-- [2 4 5]+-- >>> run [i|+ [1_2_3 4_5_6] [1 2]|]+-- ╭─+-- ╷ 2 3 4+--   6 7 8+--         ╯+-- >>> run [i|+ [1 2] [1_2_3 4_5_6]|]+-- ╭─+-- ╷ 2 3 4+--   6 7 8+--         ╯+add :: ArrayU -> ArrayU -> Res+add (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.add x y++-- | -+--+-- >>> run [i|-2 1|]+-- ¯1+-- >>> run [i|-2 [1 2 3]|]+-- [¯1 0 1]+-- >>> run [i|-[1 2 3] [4 5 6]|]+-- [3 3 3]+subtract :: ArrayU -> ArrayU -> Res+subtract (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.subtract x y++-- | ×+--+-- >>> run [i|×2 1|]+-- 2+-- >>> run [i|×2 [1 2 3]|]+-- [2 4 6]+multiply :: ArrayU -> ArrayU -> Res+multiply (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.multiply x y++-- | ÷+--+-- >>> run [i|÷2 1|]+-- 0.5+divide :: ArrayU -> ArrayU -> Res+divide (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.divide x y++-- | ◿+--+-- >>> run [i|◿10 27|]+-- 7+-- >>> run [i|◿5 [3 7 14]|]+-- [3 2 4]+modulus :: ArrayU -> ArrayU -> Res+modulus (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.modulus x y++-- | doctest bug+power :: ArrayU -> ArrayU -> Res+power (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.power x y++-- | doctest bug+logarithm :: ArrayU -> ArrayU -> Res+logarithm (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.logarithm x y++-- | ↧+--+-- >>> run [i|↧ 3 5|]+-- 3+-- >>> run [i|↧ [1 4 2] [3 7 1]|]+-- [1 4 1]+minimum :: ArrayU -> ArrayU -> Res+minimum (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.minimum x y++-- | ↥+--+-- >>> run [i|↥ 3 5|]+-- 5+-- >>> run [i|↥ [1 4 2] [3 7 1]|]+-- [3 7 2]+maximum :: ArrayU -> ArrayU -> Res+maximum (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.maximum x y++-- | ∠+--+-- >>> run [i|∠ 1 0|]+-- 1.5707963267948966+-- >>> run [i|∠ ¯1 0|]+-- ¯1.5707963267948966+atangent :: ArrayU -> ArrayU -> Res+atangent (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.atangent x y++-- | ≍+--+-- >>> run [i|≍ 1_2_3 [1 2 3]|]+-- 1+-- >>> run [i|≍ 1_2_3 1_2|]+-- 0+match :: ArrayU -> ArrayU -> Res+match (ArrayU x) (ArrayU y) = Right . pure . ArrayU . fmap fromIntegral $ A.match x y++-- | ⊟+--+-- >>> run [i|⊟ 1 2|]+-- [1 2]+-- >>> run [i|⊟ [1 2 3] [4 5 6]|]+-- ╭─+-- ╷ 1 2 3+--   4 5 6+--         ╯+couple :: ArrayU -> ArrayU -> Res+couple (ArrayU x) (ArrayU y) = Right . pure . ArrayU $ A.couple x y++-- | ⊂+--+-- >>> run [i|⊂ 1 2|]+-- [1 2]+-- >>> run [i|⊂ [1 2 3] [4 5 6]|]+-- [1 2 3 4 5 6]+-- >>> run [i|⊂ 1 [2 3]|]+-- [1 2 3]+-- >>> run [i|⊂ [1 2] 3|]+-- [1 2 3]+-- >>> run [i|⊂ [1_2 3_4] 5_6|]+-- ╭─+-- ╷ 1 2+--   3 4+--   5 6+--       ╯+-- >>> run [i|⊂ [1_2] [3_4 5_6]|]+-- ╭─+-- ╷ 1 2+--   3 4+--   5 6+--       ╯+-- >>> run [i|⊂ 0 [1_2 3_4]|]+-- ╭─+-- ╷ 0 0+--   1 2+--   3 4+--       ╯+-- >>> run [i|⊂ [1_2 3_4] 0|]+-- ╭─+-- ╷ 1 2+--   3 4+--   0 0+--       ╯+join :: ArrayU -> ArrayU -> Res+join (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) (A.join x y)++-- | ⊂+--+-- >>> run [i|⊏ 2 [8 3 9 2 0]|]+-- 9+-- >>> run [i|⊏ 4_2 [8 3 9 2 0]|]+-- [0 9]+-- >>> run [i|⊏ 0_2_1_1 [1_2_3 4_5_6 7_8_9]|]+-- ╭─+-- ╷ 1 2 3+--   7 8 9+--   4 5 6+--   4 5 6+--         ╯+-- >>> run [i|⊏ [0_1 1_2 2_3] [2 3 5 7]|]+-- ╭─+-- ╷ 2 3+--   3 5+--   5 7+--       ╯+select :: ArrayU -> ArrayU -> Res+select (ArrayU x) (ArrayU y) = Right . pure . ArrayU $ A.select (fmap asInt x) y++-- | ⊡+--+-- >>> run [i|⊡ [1_2 0_1] [1_2_3 4_5_6]|]+-- [6 2]+-- >>> run [i|⊡ 2_1 [8 3 9 2 0]|]+-- 9+-- >>> run [i|⊡ 1 [1_2_3 4_5_6]|]+-- [4 5 6]+pick :: ArrayU -> ArrayU -> Res+pick (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.pick (fmap asInt x) y++-- | ↯+--+-- >>> run [i|↯ 2_3 [1 2 3 4 5 6]|]+-- ╭─+-- ╷ 1 2 3+--   4 5 6+--         ╯+-- >>> run [i|↯ 2_2 [1_2_3 4_5_6]|]+-- ╭─+-- ╷ 1 2+--   3 4+--       ╯+-- >>> run [i|↯ [5] 2|]+-- [2 2 2 2 2]+-- >>> run [i|↯ 3_7 1_2_3_4|]+-- ╭─+-- ╷ 1 2 3 4 1 2 3+--   4 1 2 3 4 1 2+--   3 4 1 2 3 4 1+--                 ╯+-- >>> run [i|↯ 4 [1 2 3 4 5]|]+-- ╭─+-- ╷ 1 2 3 4 5+--   1 2 3 4 5+--   1 2 3 4 5+--   1 2 3 4 5+--             ╯+-- >>> run [i|↯ 2 [1_2_3 4_5_6]|]+-- ╭─+-- ╷ 1 2 3+-- ╷ 4 5 6+-- ...+--   1 2 3+--   4 5 6+--         ╯+reshape :: ArrayU -> ArrayU -> Res+reshape (ArrayU x) (ArrayU y) = Right . pure . ArrayU $ A.reshape (fmap asInt x) y++-- | ☇+--+-- >>> run [i|☇ 1 ↯2_3_3⇡18|]+-- ╭─+-- ╷  0  1  2+--    3  4  5+--    6  7  8+--    9 10 11+--   12 13 14+--   15 16 17+--            ╯+-- >>> run [i|△☇ 3 ↯2_3_3⇡18|]+-- [1 2 3 3]+rerank :: ArrayU -> ArrayU -> Res+rerank (ArrayU x) (ArrayU y) = A.rerank (fmap asInt x) y & fmap (pure . ArrayU)++-- | ↙+--+-- >>> run [i|↙ [3] [8 3 9 2 0]|]+-- [8 3 9]+take :: ArrayU -> ArrayU -> Res+take (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.take (fmap asInt x) y++-- | ↘+--+-- >>> run [i|↘ 3 [8 3 9 2 0]|]+-- [2 0]+drop :: ArrayU -> ArrayU -> Res+drop (ArrayU x) (ArrayU y) = fmap (pure . ArrayU) $ A.drop (fmap asInt x) y++-- | ↻+--+-- >>> run [i|↻1 ⇡5|]+-- [1 2 3 4 0]+rotate :: ArrayU -> ArrayU -> Res+rotate (ArrayU x) (ArrayU y) = Right . pure . ArrayU $ A.rotate (fmap asInt x) y++-- | ▽+--+-- >>> run [i|▽ [3 2] [8 3 9 2 0]|]+-- [8 8 8 3 3 9 9 9 2 2 0 0 0]+keep :: ArrayU -> ArrayU -> Res+keep (ArrayU x) (ArrayU y) = Right . pure . ArrayU $ A.keep (fmap asInt x) y++-- | ◫+--+-- >>> run [i|◫2 ⇡4|]+-- ╭─+-- ╷ 0 1+--   1 2+--   2 3+--       ╯+windows :: ArrayU -> ArrayU -> Res+windows (ArrayU x) (ArrayU y) = Right . pure . ArrayU $ A.windows (fmap asInt x) y++-- | ⌕+--+-- >>> run [i|⌕ [5] [1 8 5 2 3 5 4 5 6 7]|]+-- [0 0 1 0 0 1 0 1 0 0]+-- >>> run [i|⌕ [1_2 2_0] ↯4_4⇡3|]+-- ╭─+-- ╷ 0 1 0 0+--   1 0 0 0+--   0 0 1 0+--   0 0 0 0+--           ╯+find :: ArrayU -> ArrayU -> Res+find (ArrayU x) (ArrayU y) = Right . pure . ArrayU . fmap fromIntegral $ A.find x y++-- | ⦷+--+-- >>> run [i|⦷ [1_1 1_1] ↯ [5 5] 1|]+-- ╭─+-- ╷ 1 1 2 2 0+--   1 1 2 2 0+--   3 3 4 4 0+--   3 3 4 4 0+--   0 0 0 0 0+--             ╯+mask :: ArrayU -> ArrayU -> Res+mask (ArrayU x) (ArrayU y) = Right . pure . ArrayU . fmap fromIntegral $ A.mask x y++-- | /=+--+-- >>> run [i|/=[0_1_0 0_4_3]|]+-- [1 0 0]+equalsR :: ArrayU -> Res+equalsR (ArrayU x) = Right . pure . ArrayU . fmap fromIntegral $ A.equalsR x++-- | /≠+--+-- >>> run [i|/≠[0_1_0 0_4_3]|]+-- [0 1 1]+notEqualsR :: ArrayU -> Res+notEqualsR (ArrayU x) = Right . pure . ArrayU . fmap fromIntegral $ A.notEqualsR x++-- | /<+--+-- >>> run [i|/<[2_1_0 0_4_3]|]+-- [1 0 0]+lessThanR :: ArrayU -> Res+lessThanR (ArrayU x) = Right . pure . ArrayU . fmap fromIntegral $ A.lessThanR x++-- | /≤+--+-- >>> run [i|/≤[0_1_0 0_4_3]|]+-- [1 0 0]+lessOrEqualR :: ArrayU -> Res+lessOrEqualR (ArrayU x) = Right . pure . ArrayU . fmap fromIntegral $ A.lessOrEqualR x++-- | />+--+-- >>> run [i|/>[0_1_0 0_4_3]|]+-- [0 1 1]+greaterThanR :: ArrayU -> Res+greaterThanR (ArrayU x) = Right . pure . ArrayU . fmap fromIntegral $ A.greaterThanR x++-- | /≥+--+-- >>> run [i|/≥[0_1_0 0_4_3]|]+-- [1 1 1]+greaterOrEqualR :: ArrayU -> Res+greaterOrEqualR (ArrayU x) = Right . pure . ArrayU . fmap fromIntegral $ A.greaterOrEqualR x++-- | /++--+-- >>> run [i|/+[0_1_0 0_4_3]|]+-- [0 5 3]+addR :: ArrayU -> Res+addR (ArrayU x) = Right $ pure $ ArrayU $ A.addR x++-- | /-+--+-- >>> run [i|/- 1_2_3|]+-- 2+-- >>> run [i|/- [1_2_3 4_5_6]|]+-- [3 3 3]+subtractR :: ArrayU -> Res+subtractR (ArrayU x) = Right $ pure $ ArrayU $ A.subtractR x++-- | /×+--+-- >>> run [i|/× 1_2_3|]+-- 6+-- >>> run [i|/× [1_2_3 4_5_6]|]+-- [4 10 18]+multiplyR :: ArrayU -> Res+multiplyR (ArrayU x) = Right $ pure $ ArrayU $ A.multiplyR x++-- | /÷+--+-- >>> run [i|/÷ 1_2_3|]+-- 1.5+-- >>> run [i|/÷ [1_2_3 4_5_6]|]+-- [4 2.5 2]+divideR :: ArrayU -> Res+divideR (ArrayU x) = Right $ pure $ ArrayU $ A.divideR x++-- | /◿+--+-- >>> run [i|/◿ []|]+-- Infinity+-- >>> run [i|/◿ [2]|]+-- 2+-- >>> run [i|/◿ 2_1|]+-- 1+-- >>> run [i|/◿ [1_2_3 4_5_6]|]+-- [0 1 0]+modulusR :: ArrayU -> Res+modulusR (ArrayU x) = Right $ pure $ ArrayU $ A.modulusR x++-- | doctest subscript bug. see readme for test+powerR :: ArrayU -> Res+powerR (ArrayU x) = Right $ pure $ ArrayU $ A.powerR x++-- | doctest subscript bug. see readme for test+logarithmR :: ArrayU -> Res+logarithmR (ArrayU x) = fmap (pure . ArrayU) $ A.logarithmR x++-- | /↧+--+-- >>> run [i|/↧ []|]+-- Infinity+-- >>> run [i|/↧ [2]|]+-- 2+-- >>> run [i|/↧ 2_1|]+-- 1+-- >>> run [i|/↧ [1_2_3 4_5_6]|]+-- [1 2 3]+minimumR :: ArrayU -> Res+minimumR (ArrayU x) = Right $ pure $ ArrayU $ A.minimumR x++-- | /↥+--+-- >>> run [i|/↥ []|]+-- ¯Infinity+-- >>> run [i|/↥[2]|]+-- 2+-- >>> run [i|/↥ 2_1|]+-- 2+-- >>> run [i|/↥ [1_2_3 4_5_6]|]+-- [4 5 6]+maximumR :: ArrayU -> Res+maximumR (ArrayU x) = Right $ pure $ ArrayU $ A.maximumR x
+ src/Huihua/Examples.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE QuasiQuotes #-}++module Huihua.Examples where++import Data.ByteString (ByteString)+import Data.String.Interpolate+import Data.Text.Encoding (encodeUtf8)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XQuasiQuotes+-- >>> import Prelude+-- >>> import Data.String.Interpolate+-- >>> import Huihua.Examples+-- >>> import Huihua.Parse as P+-- >>> import Harpie.Array as A+-- >>> import Data.List qualified as List+-- >>> import Data.ByteString.Char8 qualified as C+-- >>> import FlatParse.Basic+-- >>> import Data.Function ((&))+--+-- yet to be implemented+--+-- infinite and negative axes in reshape+--+-- multi-line arrays+--+-- >>> run nyiMultiArray+-- 7+-- 8+-- 9+--+--+-- ... format+-- >>> run [i|÷ 3 1|]+-- 0.3333333333333333+--+-- negate strand combination.+-- >>> run [i|¯2_¯2|]+-- ¯2+--+-- Implemented:+--+-- broadcasting scalars (and prefixed arrays?)+--+-- >>> run [i|<2 [1 2 3]|]+-- [1 0 0]+--+-- multi-dim bool reductions+-- >>> run [i|/<[2_1_0 0_4_3]|]+-- [1 0 0]+--+-- operators and stuff inside square brackets+--+-- >>> run "[. 1 2 3 4]"+-- [1 1 2 3 4]+--+-- display negate sign for numbers+--+-- >>> run [i|¯1|]+-- ¯1+--+-- strand square bracket combination+--+-- >>> run [i|[1_2 3_4 5_6]|]+-- ╭─+-- ╷ 1 2+--   3 4+--   5 6+--       ╯++-- |+--+-- >>> run exPage1+-- 4+exPage1 :: ByteString+exPage1 =+  encodeUtf8+    [i|+[1 5 8 2]+/+. \# Sum+⧻:  \# Length+÷   \# Divide+|]++-- |+--+-- >>> run exPage2+-- ╭─+-- ╷  0  1  2  3+-- ╷  4  5  6  7+--    8  9 10 11+-- ...+--   12 13 14 15+--   16 17 18 19+--   20 21 22 23+--               ╯+exPage2 :: ByteString+exPage2 =+  encodeUtf8+    [i|+2_3_4+/×. \# Product+⇡   \# Range+↯:  \# Reshape+|]++-- | character arrays not yet implemented.+--+-- >>> exPage3 & C.lines & fmap (runParser tokens)+-- [OK [] "",OK [GlyphToken String,NameToken "Unabashedly",NameToken "I",NameToken "utilize",NameToken "arrays",GlyphToken String] "",OK [GlyphToken NotEquals,CharacterToken ' ',GlyphToken Duplicate,CommentToken " Mask of non-spaces"] "",OK [GlyphToken Partition,GlyphToken First,CommentToken " All first letters"] ""]+exPage3 :: ByteString+exPage3 =+  [i|+"Unabashedly I utilize arrays"+≠@ . \# Mask of non-spaces+⊜⊢   \# All first letters+|]++nyiMultiArray :: ByteString+nyiMultiArray =+  [i|+[1 2 3+ 4 5 6+ 7 8 9]+|]
+ src/Huihua/Glyphs.hs view
@@ -0,0 +1,462 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++module Huihua.Glyphs where++import Data.ByteString (ByteString)+import Data.Function ((&))+import Data.Map.Strict qualified as Map+import Harpie.Array qualified as D+import Huihua.ArrayU as U+import Huihua.Stack+import Huihua.Warning+import Prelude as P hiding (null)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Huihua.Parse as P+-- >>> import Harpie.Array as A++data InputArity = Monadic | Dyadic deriving (Eq, Show)++data OutputArity = NoOutput | SingleOutput | DoubleOutput deriving (Eq, Show)++data Action = Pervasive | ArrayAction deriving (Eq, Show)++data Reducing = Reducing | NotReducing deriving (Eq, Show)++data Modifier = Iterating | Aggregating | Inversion | OtherModifier deriving (Eq, Show)++data StackOp = BasicStack | Planet deriving (Eq, Show)++data GlyphCategory = StackG StackOp | ConstantG | OperatorG InputArity OutputArity Action | ModifierG Modifier | MiscellaneousG | NonOperatorG deriving (Eq, Show)++data Glyph+  = -- StackG BasicStack+    Identity+  | Duplicate+  | Over+  | Flip+  | Pop+  | On+  | By+  | Stack'+  | Trace+  | Dump+  | -- StackG Planet+    Gap+  | Dip+  | Both+  | Fork+  | Bracket+  | -- ConstantG+    Eta+  | Pi+  | Tau+  | Infinity+  | -- OpertorG Monadic _ Pervasive+    Not+  | Sign+  | Negate+  | AbsoluteValue+  | Sqrt+  | Sine+  | Floor+  | Ceiling+  | Round+  | -- OperatorG Dyadic _ Pervasive+    Equals+  | NotEquals+  | LessThan+  | LessOrEqual+  | GreaterThan+  | GreaterOrEqual+  | Add+  | Subtract+  | Multiply+  | Divide+  | Modulus+  | Power+  | Logarithm+  | Minimum+  | Maximum+  | Atangent+  | Complex'+  | -- OperatorG Monadic _ ArrayAction+    Length+  | Shape+  | Range+  | First+  | Reverse+  | Deshape+  | Fix+  | Bits+  | Transpose+  | Rise+  | Fall+  | Where+  | Classify+  | Deduplicate+  | Unique+  | Box+  | -- OperatorG Monadic _ ArrayAction+    Match+  | Couple+  | Join+  | Select+  | Pick+  | Reshape+  | Rerank+  | Take+  | Drop+  | Rotate+  | Windows+  | Keep+  | Find+  | Mask+  | Member+  | IndexOf+  | Coordinate+  | -- ModifierG Iterating+    Each+  | Rows+  | Table+  | Inventory+  | Repeat+  | Do+  | -- ModifierG Aggregating+    Reduce+  | Fold+  | Scan+  | Group+  | Partition+  | -- ModifierG Inversion+    Un+  | Setinv+  | Setund+  | Under+  | -- ModifierG OtherModifier+    Content+  | Fill+  | -- MiscellaneousG+    Parse+  | Try+  | Assert+  | Random+  | -- NonOperatorG+    Strand+  | ArrayLeft+  | ArrayRight+  | BoxArrayLeft+  | BoxArrayRight+  | FunctionLeft+  | FunctionRight+  | SwitchLeft+  | SwitchRight+  | Negative+  | Character+  | Format+  | String+  | Macro+  | Placeholder+  | Binding+  | PrivateBinding+  | Import'+  | Signature+  | Comment+  deriving (Eq, Ord, Show)++data GlyphDeets = GlyphDeets {glyph :: Glyph, symbol :: ByteString, glyphCategory :: GlyphCategory}++glyphM :: Map.Map Glyph GlyphDeets+glyphM = Map.fromList $ zip (fmap glyph glyphs) glyphs++glyphs :: [GlyphDeets]+glyphs =+  [ -- StackG BasicStack+    GlyphDeets Identity "∘" (StackG BasicStack),+    GlyphDeets Duplicate "." (StackG BasicStack),+    GlyphDeets Over "," (StackG BasicStack),+    GlyphDeets Flip "∶" (StackG BasicStack),+    GlyphDeets Pop "◌" (StackG BasicStack),+    GlyphDeets On "⟜" (StackG BasicStack),+    GlyphDeets By "⊸" (StackG BasicStack),+    GlyphDeets Stack' "?" (StackG BasicStack),+    GlyphDeets Trace "⸮" (StackG BasicStack),+    GlyphDeets Dump "dump" (StackG BasicStack),+    -- StackG Planet+    GlyphDeets Gap "⋅" (StackG Planet),+    GlyphDeets Dip "⊙" (StackG Planet),+    GlyphDeets Both "∩" (StackG Planet),+    GlyphDeets Fork "⊃" (StackG Planet),+    GlyphDeets Bracket "⊓" (StackG Planet),+    -- ConstantG+    GlyphDeets Eta "η" ConstantG,+    GlyphDeets Pi "π" ConstantG,+    GlyphDeets Tau "τ" ConstantG,+    GlyphDeets Infinity "∞" ConstantG,+    -- OpertorG Monadic _ Pervasive+    GlyphDeets Not "¬" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets Sign "±" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets Negate "¯" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets AbsoluteValue "⌵" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets Sqrt "√" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets Sine "○" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets Floor "⌊" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets Ceiling "⌈" (OperatorG Monadic SingleOutput Pervasive),+    GlyphDeets Round "⁅" (OperatorG Monadic SingleOutput Pervasive),+    -- OperatorG Dyadic _ Pervasive+    GlyphDeets Equals "=" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets NotEquals "≠" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets LessThan "&lt;" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets LessOrEqual "≤" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets GreaterThan "&gt;" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets GreaterOrEqual "≥" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Add "+" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Subtract "-" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Multiply "×" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Divide "÷" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Modulus "◿" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Power "ⁿ" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Logarithm "ₙ" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Minimum "↧" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Maximum "↥" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Atangent "∠" (OperatorG Dyadic SingleOutput Pervasive),+    GlyphDeets Complex' "ℂ" (OperatorG Dyadic SingleOutput Pervasive),+    -- OperatorG Monadic _ ArrayAction+    GlyphDeets Length "⧻" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Shape "△" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Range "⇡" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets First "⊢" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Reverse "⇌" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Deshape "♭" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Fix "¤" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Bits "⋯" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Transpose "⍉" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Rise "⍏" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Fall "⍖" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Where "⊚" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Classify "⊛" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Deduplicate "⊝" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Unique "◰" (OperatorG Monadic SingleOutput ArrayAction),+    GlyphDeets Box "□" (OperatorG Monadic SingleOutput ArrayAction),+    -- OperatorG Monadic _ ArrayAction+    GlyphDeets Match "≅" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Couple "⊟" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Join "⊂" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Select "⊏" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Pick "⊡" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Reshape "↯" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Rerank "☇" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Take "↙" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Drop "↘" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Rotate "↻" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Windows "◫" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Keep "▽" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Find "⌕" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Mask "⦷" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Member "∊" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets IndexOf "⊗" (OperatorG Dyadic SingleOutput ArrayAction),+    GlyphDeets Coordinate "⟔" (OperatorG Dyadic SingleOutput ArrayAction),+    -- ModifierG Iterating+    GlyphDeets Each "∵" (ModifierG Iterating),+    GlyphDeets Rows "≡" (ModifierG Iterating),+    GlyphDeets Table "⊞" (ModifierG Iterating),+    GlyphDeets Inventory "⍚" (ModifierG Iterating),+    GlyphDeets Repeat "⍥" (ModifierG Iterating),+    GlyphDeets Do "⍢" (ModifierG Iterating),+    -- ModifierG Aggregating+    GlyphDeets Reduce "/" (ModifierG Aggregating),+    GlyphDeets Fold "∧" (ModifierG Aggregating),+    GlyphDeets Scan "\\" (ModifierG Aggregating),+    GlyphDeets Group "⊕" (ModifierG Aggregating),+    GlyphDeets Partition "⊜" (ModifierG Aggregating),+    -- ModifierG Inversion+    GlyphDeets Un "°" (ModifierG Inversion),+    GlyphDeets Setinv "setinv" (ModifierG Inversion),+    GlyphDeets Setund "setund" (ModifierG Inversion),+    GlyphDeets Under "⍜" (ModifierG Inversion),+    -- ModifierG OtherModifier+    GlyphDeets Content "◇" (ModifierG OtherModifier),+    GlyphDeets Fill "⬚" (ModifierG OtherModifier),+    -- MiscellaneousG+    GlyphDeets Parse "⋕" MiscellaneousG,+    GlyphDeets Try "⍣" MiscellaneousG,+    GlyphDeets Assert "⍤" MiscellaneousG,+    GlyphDeets Random "⚂" MiscellaneousG,+    -- NonOperatorG+    GlyphDeets Strand "_" NonOperatorG,+    GlyphDeets ArrayLeft "[" NonOperatorG,+    GlyphDeets ArrayRight "]" NonOperatorG,+    GlyphDeets BoxArrayLeft "{" NonOperatorG,+    GlyphDeets BoxArrayRight "}" NonOperatorG,+    GlyphDeets FunctionLeft "(" NonOperatorG,+    GlyphDeets FunctionRight ")" NonOperatorG,+    GlyphDeets SwitchLeft "⟨" NonOperatorG,+    GlyphDeets SwitchRight "⟩" NonOperatorG,+    GlyphDeets Negative "¯" NonOperatorG,+    GlyphDeets Character "@" NonOperatorG,+    GlyphDeets Format "@" NonOperatorG,+    GlyphDeets String "$" NonOperatorG,+    GlyphDeets Macro "!" NonOperatorG,+    GlyphDeets Placeholder "^" NonOperatorG,+    GlyphDeets Binding "←" NonOperatorG,+    GlyphDeets PrivateBinding "↚" NonOperatorG,+    GlyphDeets Import' "~" NonOperatorG,+    GlyphDeets Signature "|" NonOperatorG,+    GlyphDeets Comment "#" NonOperatorG+  ]++isOperator :: Glyph -> Bool+isOperator g = case fmap glyphCategory (Map.lookup g glyphM) of+  (Just (OperatorG {})) -> True+  (Just (StackG BasicStack)) -> True+  (Just ConstantG) -> True+  _ -> False++isNonadicOp :: Glyph -> Bool+isNonadicOp Random = True+isNonadicOp g = Just ConstantG == fmap glyphCategory (Map.lookup g glyphM)++isMonadicOp :: Glyph -> Bool+isMonadicOp g = case fmap glyphCategory (Map.lookup g glyphM) of+  (Just (OperatorG Monadic _ _)) -> True+  _ -> False++isDyadicOp :: Glyph -> Bool+isDyadicOp g = case fmap glyphCategory (Map.lookup g glyphM) of+  (Just (OperatorG Dyadic _ _)) -> True+  _ -> False++isStackOp :: Glyph -> Bool+isStackOp g = case fmap glyphCategory (Map.lookup g glyphM) of+  (Just (StackG _)) -> True+  _ -> False++applyStack :: Glyph -> Stack -> Either HuihuaWarning Stack+applyStack Identity (Stack (x : xs)) = Right (Stack (x : xs))+applyStack Duplicate (Stack (x : xs)) = Right (Stack (x : x : xs))+applyStack Over (Stack (x : y : xs)) = Right (Stack (y : x : y : xs))+applyStack Flip (Stack (x : y : xs)) = Right (Stack (y : x : xs))+applyStack Pop (Stack (_ : xs)) = Right (Stack xs)+applyStack On _ = Left NYI+applyStack By _ = Left NYI+applyStack Stack' _ = Left NYI+applyStack Trace _ = Left NYI+applyStack Dump _ = Left NYI+applyStack Gap _ = Left NYI+applyStack Dip _ = Left NYI+applyStack Both _ = Left NYI+applyStack Fork _ = Left NYI+applyStack _ (Stack []) = Left EmptyStack1+applyStack _ (Stack [_]) = Left EmptyStack2++applyNonadic :: Glyph -> Res+applyNonadic Eta = Right $ pure $ ArrayU (D.toScalar $ 0.5 * pi)+applyNonadic Pi = Right $ pure $ ArrayU (D.toScalar pi)+applyNonadic Tau = Right $ pure $ ArrayU (D.toScalar $ 2 * pi)+applyNonadic Infinity = Right $ pure $ ArrayU (D.toScalar $ 1 / 0)+applyNonadic Random = Left NYI+applyNonadic _ = Left NYI++applyMonadic :: Glyph -> ArrayU -> Res+applyMonadic Not x = U.not x+applyMonadic Sign x = U.sign x+applyMonadic Negate x = U.negate' x+applyMonadic AbsoluteValue x = U.absoluteValue x+applyMonadic Sqrt x = U.sqrt x+applyMonadic Sine x = U.sine x+applyMonadic Floor x = U.floor x+applyMonadic Ceiling x = U.ceiling x+applyMonadic Round x = U.round x+applyMonadic Length x = U.length x+applyMonadic Shape x = U.shape x+applyMonadic Range x = U.range x+applyMonadic First x = U.first x+applyMonadic Reverse x = U.reverse x+applyMonadic Deshape x = U.deshape x+applyMonadic Bits x = U.bits x+applyMonadic Fix x = U.fix x+applyMonadic Transpose x = U.transpose x+applyMonadic Rise x = U.rise x+applyMonadic Fall x = U.fall x+applyMonadic Where x = U.where' x+applyMonadic Classify x = U.classify x+applyMonadic Deduplicate x = U.deduplicate x+applyMonadic Unique x = U.unique x+applyMonadic _ _ = Left NYI++applyDyadic :: Glyph -> ArrayU -> ArrayU -> Res+applyDyadic Equals x y = U.equals x y+applyDyadic NotEquals x y = U.notequals x y+applyDyadic LessThan x y = U.lessThan x y+applyDyadic LessOrEqual x y = U.lessOrEqual x y+applyDyadic GreaterThan x y = U.greaterThan x y+applyDyadic GreaterOrEqual x y = U.greaterOrEqual x y+applyDyadic Add x y = U.add x y+applyDyadic Subtract x y = U.subtract x y+applyDyadic Multiply x y = U.multiply x y+applyDyadic Divide x y = U.divide x y+applyDyadic Modulus x y = U.modulus x y+applyDyadic Power x y = U.power x y+applyDyadic Logarithm x y = U.logarithm x y+applyDyadic Minimum x y = U.minimum x y+applyDyadic Maximum x y = U.maximum x y+applyDyadic Atangent x y = U.atangent x y+applyDyadic Complex' _ _ = undefined+applyDyadic Match x y = U.match x y+applyDyadic Couple x y = U.couple x y+applyDyadic Join x y = U.join x y+applyDyadic Select x y = U.select x y+applyDyadic Pick x y = U.pick x y+applyDyadic Reshape x y = U.reshape x y+applyDyadic Rerank x y = U.rerank x y+applyDyadic Take x y = U.take x y+applyDyadic Drop x y = U.drop x y+applyDyadic Rotate x y = U.rotate x y+applyDyadic Windows x y = U.windows x y+applyDyadic Keep x y = U.keep x y+applyDyadic Find x y = U.find x y+applyDyadic Mask x y = U.mask x y+applyDyadic Member x y = U.member x y+applyDyadic IndexOf x y = U.indexOf x y+applyDyadic _ _ _ = Left NYI++pushRes :: [ArrayU] -> Res -> Either HuihuaWarning Stack+pushRes xs (Right rs) = Right (Stack (rs <> xs))+pushRes _ (Left e) = Left e++applyOp :: Glyph -> Stack -> Either HuihuaWarning Stack+applyOp g s+  | isStackOp g = applyStack g s+  | isNonadicOp g = applyNonadic g & pushRes (stackList s)+  | isMonadicOp g = case s of+      (Stack []) -> Left EmptyStack1+      (Stack (x : xs)) -> applyMonadic g x & pushRes xs+  | isDyadicOp g = case s of+      (Stack []) -> Left EmptyStack1+      (Stack [_]) -> Left EmptyStack2+      (Stack (x : y : xs)) -> applyDyadic g x y & pushRes xs+  | otherwise = Left ApplyNonOperator++applyReduceOp :: Glyph -> Stack -> Either HuihuaWarning Stack+applyReduceOp _ (Stack []) = Left EmptyStack1+applyReduceOp g (Stack (x : xs)) = reduceOp g x & pushRes xs++reduceOp :: Glyph -> ArrayU -> Res+reduceOp Equals x = U.equalsR x+reduceOp NotEquals x = U.notEqualsR x+reduceOp LessThan x = U.lessThanR x+reduceOp LessOrEqual x = U.lessOrEqualR x+reduceOp GreaterThan x = U.greaterThanR x+reduceOp GreaterOrEqual x = U.greaterOrEqualR x+reduceOp Add x = U.addR x+reduceOp Subtract x = U.subtractR x+reduceOp Multiply x = U.multiplyR x+reduceOp Divide x = U.divideR x+reduceOp Modulus x = U.modulusR x+reduceOp Power x = U.powerR x+reduceOp Logarithm x = U.logarithmR x+reduceOp Minimum x = U.minimumR x+reduceOp Maximum x = U.maximumR x+reduceOp _ _ = Left NYI
+ src/Huihua/Parse.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Huihua.Parse where++import Control.Applicative as A+import Control.Monad+import Data.Bifunctor+import Data.Bool (bool)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as C+import Data.Function ((&))+import Data.List qualified as List+import FlatParse.Basic as FP+import Harpie.Array (Array)+import Harpie.Array qualified as D+import Huihua.ArrayU+import Huihua.Glyphs+import Huihua.Parse.FlatParse+import Huihua.Stack as S+import Huihua.Warning+import Prettyprinter+import Prelude as P hiding (null)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Huihua.Parse as P+-- >>> import Harpie.Array as A+-- >>> import Data.List qualified as List+-- >>> import Huihua.Examples+-- >>> import Prettyprinter++data Token = StringToken ByteString | GlyphToken Glyph | DoubleToken Double | CharacterToken Char | NameToken String | CommentToken ByteString | TypeToken deriving (Eq, Ord, Show)++-- | Double token has precedence over duplicate+token :: Parser e Token+token =+  (DoubleToken <$> double)+    FP.<|> (CharacterToken <$> ($(char '@') *> anyChar))+    FP.<|> (CommentToken <$> ($(char '#') *> takeRest))+    FP.<|> (GlyphToken <$> glyphP)+    FP.<|> (StringToken <$> wrappedDq)+    FP.<|> (NameToken <$> some (satisfy isLatinLetter))+    FP.<|> (TypeToken <$ $(string "type"))++tokens :: Parser e [Token]+tokens = many (ws_ *> token) <* ws_++tokenize :: ByteString -> Either ByteString [[Token]]+tokenize bs = runParserEither (many tokens) bs++newtype Assembler t a = Assembler {assemble :: [t] -> Maybe (a, [t])} deriving (Functor)++instance Applicative (Assembler t) where+  pure a = Assembler (\xs -> Just (a, xs))++  f <*> a = Assembler $ \xs -> case assemble f xs of+    Nothing -> Nothing+    Just (f', xs') -> case assemble a xs' of+      Nothing -> Nothing+      Just (a', xs'') -> Just (f' a', xs'')++instance Alternative (Assembler t) where+  empty = Assembler (const Nothing)+  (<|>) a b = Assembler $ \xs -> case assemble a xs of+    Nothing -> assemble b xs+    Just x -> Just x++aOp :: Assembler Token Glyph+aOp = Assembler $ \case+  (GlyphToken g : xs) -> bool Nothing (Just (g, xs)) (isOperator g)+  _ -> Nothing++aNoOp :: Assembler Token Glyph+aNoOp = Assembler $ \case+  (GlyphToken g : xs) -> bool (Just (g, xs)) Nothing (P.not $ isOperator g)+  _ -> Nothing++aReduce :: Assembler Token ()+aReduce = Assembler $ \case+  (GlyphToken Reduce : xs) -> Just ((), xs)+  _ -> Nothing++aReduceOp :: Assembler Token Glyph+aReduceOp = Assembler $ \case+  (GlyphToken Reduce : GlyphToken g : xs) -> bool Nothing (Just (g, xs)) (isOperator g)+  _ -> Nothing++aComment :: Assembler Token ByteString+aComment = Assembler $ \case+  (CommentToken c : xs) -> Just (c, xs)+  _ -> Nothing++aDouble :: Assembler Token Double+aDouble = Assembler $ \case+  (DoubleToken d : xs) -> Just (d, xs)+  _ -> Nothing++aChar :: Assembler Token Char+aChar = Assembler $ \case+  (CharacterToken x : xs) -> Just (x, xs)+  _ -> Nothing++aString :: Assembler Token ByteString+aString = Assembler $ \case+  (StringToken x : xs) -> Just (x, xs)+  _ -> Nothing++aArrayRight :: Assembler Token ()+aArrayRight = Assembler $ \case+  (GlyphToken ArrayRight : xs) -> Just ((), xs)+  _ -> Nothing++aArrayLeft :: Assembler Token ()+aArrayLeft = Assembler $ \case+  (GlyphToken ArrayLeft : xs) -> Just ((), xs)+  _ -> Nothing++aStrand :: Assembler Token ()+aStrand = Assembler $ \case+  (GlyphToken Strand : xs) -> Just ((), xs)+  _ -> Nothing++aArray :: Assembler Token a -> Assembler Token (Array a)+aArray a = aArrayLeft *> (D.asArray <$> many a) <* aArrayRight++aArrayStrand :: Assembler Token a -> Assembler Token (Array a)+aArrayStrand a = fmap D.asArray . (:) <$> a <*> some (aStrand *> a)++aToken :: Assembler Token Token+aToken = Assembler $ \case+  (x : xs) -> Just (x, xs)+  _ -> Nothing++data Instruction = IOp Glyph | IReduceOp Glyph | WArray (Array Instruction) | IArray (Array Double) | INYI Token deriving (Show, Eq)++aInstruction :: Assembler Token Instruction+aInstruction =+  (IReduceOp <$> aReduceOp)+    A.<|> (IOp <$> aOp)+    A.<|> (IArray <$> aArray aDouble)+    A.<|> (IArray <$> aArrayStrand aDouble)+    A.<|> (WArray <$> aArray aInstruction)+    A.<|> (IArray . D.toScalar <$> aDouble)++aInstructions :: Assembler Token [Instruction]+aInstructions = many aInstruction++instructionize :: [Token] -> [Instruction]+instructionize ts = foldMap fst (assemble aInstructions ts)++-- |+-- >>> parseI exPage1+-- [IOp Divide,IOp Length,IOp Flip,IReduceOp Add,IOp Duplicate,IArray (UnsafeArray [4] [1.0,5.0,8.0,2.0])]+parseI :: ByteString -> [Instruction]+parseI bs = parseT bs & instructionize++-- |+-- >>> parseT exPage1+-- [GlyphToken Divide,GlyphToken Length,GlyphToken Flip,GlyphToken Reduce,GlyphToken Add,GlyphToken Duplicate,GlyphToken ArrayLeft,DoubleToken 1.0,DoubleToken 5.0,DoubleToken 8.0,DoubleToken 2.0,GlyphToken ArrayRight]+parseT :: ByteString -> [Token]+parseT bs = bs & C.lines & fmap (runParser_ tokens) & List.reverse & mconcat & filter (P.not . isComment)++isComment :: Token -> Bool+isComment (CommentToken _) = True+isComment _ = False++istep :: Instruction -> Stack -> Either HuihuaWarning Stack+istep (IOp op) s = applyOp op s+istep (IArray x) (Stack s) = Right (Stack (ArrayU x : s))+istep (WArray x) (Stack s) = second (Stack . (: s) . ArrayU) a+  where+    a = case interpI (D.arrayAs x) of+      (Right (Stack xs)) -> maybe (Left RaggedInternal) Right (D.joinSafe (D.asArray (fmap arrayd xs)))+      (Left w) -> Left w+istep (IReduceOp op) s = applyReduceOp op s+istep _ (Stack _) = Left NYI++-- | compute a list of instructions executing from right to left.+--+-- >>> interpI (parseI exPage1)+-- Right (Stack {stackList = [ArrayU {arrayd = UnsafeArray [] [4.0]}]})+interpI :: [Instruction] -> Either HuihuaWarning Stack+interpI as = foldr ((>=>) . istep) pure (List.reverse as) (Stack [])++-- |+--+-- >>> run exPage1+-- 4+run :: ByteString -> Doc ann+run bs = either viaShow pretty (interpI (parseI bs))++-- >>> sequence_ $ C.putStr <$> (ts <> ["\n"])+-- .,∶;∘¬±¯⌵√○⌊⌈⁅=≠&lt;≤&gt;≥+-×÷◿ⁿₙ↧↥∠⧻△⇡⊢⇌♭⋯⍉⍏⍖⊚⊛⊝□⊔≅⊟⊂⊏⊡↯↙↘↻◫▽⌕∊⊗/∧\∵≡∺⊞⊠⍥⊕⊜⍘⋅⊙∩⊃⊓⍜⍚⬚'?⍣⍤!⎋↬⚂ηπτ∞~_[]{}()¯@$"←|+allTheSymbols :: [ByteString]+allTheSymbols = [".", ",", "\226\136\182", ";", "\226\136\152", "\194\172", "\194\177", "\194\175", "\226\140\181", "\226\136\154", "\226\151\139", "\226\140\138", "\226\140\136", "\226\129\133", "=", "\226\137\160", "&lt;", "\226\137\164", "&gt;", "\226\137\165", "+", "-", "\195\151", "\195\183", "\226\151\191", "\226\129\191", "\226\130\153", "\226\134\167", "\226\134\165", "\226\136\160", "\226\167\187", "\226\150\179", "\226\135\161", "\226\138\162", "\226\135\140", "\226\153\173", "\226\139\175", "\226\141\137", "\226\141\143", "\226\141\150", "\226\138\154", "\226\138\155", "\226\138\157", "\226\150\161", "\226\138\148", "\226\137\133", "\226\138\159", "\226\138\130", "\226\138\143", "\226\138\161", "\226\134\175", "\226\134\153", "\226\134\152", "\226\134\187", "\226\151\171", "\226\150\189", "\226\140\149", "\226\136\138", "\226\138\151", "/", "\226\136\167", "\\", "\226\136\181", "\226\137\161", "\226\136\186", "\226\138\158", "\226\138\160", "\226\141\165", "\226\138\149", "\226\138\156", "\226\141\152", "\226\139\133", "\226\138\153", "\226\136\169", "\226\138\131", "\226\138\147", "\226\141\156", "\226\141\154", "\226\172\154", "'", "?", "\226\141\163", "\226\141\164", "!", "\226\142\139", "\226\134\172", "\226\154\130", "\206\183", "\207\128", "\207\132", "\226\136\158", "~", "_", "[", "]", "{", "}", "(", ")", "\194\175", "@", "$", "\"", "\226\134\144", "|", "#"]++glyphP :: Parser e Glyph+glyphP =+  $( switch+       [|+         case _ of+           "." -> pure Duplicate+           "," -> pure Over+           ":" -> pure Flip+           "◌" -> pure Pop+           "⟜" -> pure On+           "⊸" -> pure By+           "?" -> pure Stack'+           "⸮" -> pure Trace+           "dump" -> pure Dump+           "∘" -> pure Identity+           "⋅" -> pure Gap+           "⊙" -> pure Dip+           "∩" -> pure Both+           "⊃" -> pure Fork+           "⊓" -> pure Bracket+           "η" -> pure Eta+           "π" -> pure Pi+           "τ" -> pure Tau+           "∞" -> pure Infinity+           "¬" -> pure Not+           "±" -> pure Sign+           "¯" -> pure Negate+           "⌵" -> pure AbsoluteValue+           "√" -> pure Sqrt+           "∿" -> pure Sine+           "⌊" -> pure Floor+           "⌈" -> pure Ceiling+           "⁅" -> pure Round+           "=" -> pure Equals+           "≠" -> pure NotEquals+           "<" -> pure LessThan+           "≤" -> pure LessOrEqual+           ">" -> pure GreaterThan+           "≥" -> pure GreaterOrEqual+           "+" -> pure Add+           "-" -> pure Subtract+           "×" -> pure Multiply+           "÷" -> pure Divide+           "◿" -> pure Modulus+           "ⁿ" -> pure Power+           "ₙ" -> pure Logarithm+           "↧" -> pure Minimum+           "↥" -> pure Maximum+           "∠" -> pure Atangent+           "ℂ" -> pure Complex'+           "⧻" -> pure Length+           "△" -> pure Shape+           "⇡" -> pure Range+           "⊢" -> pure First+           "⇌" -> pure Reverse+           "♭" -> pure Deshape+           "¤" -> pure Fix+           "⋯" -> pure Bits+           "⍉" -> pure Transpose+           "⍏" -> pure Rise+           "⍖" -> pure Fall+           "⊚" -> pure Where+           "⊛" -> pure Classify+           "◴" -> pure Deduplicate+           "◰" -> pure Unique+           "□" -> pure Box+           "≍" -> pure Match+           "⊟" -> pure Couple+           "⊂" -> pure Join+           "⊏" -> pure Select+           "⊡" -> pure Pick+           "↯" -> pure Reshape+           "☇" -> pure Rerank+           "↙" -> pure Take+           "↘" -> pure Drop+           "↻" -> pure Rotate+           "◫" -> pure Windows+           "▽" -> pure Keep+           "⌕" -> pure Find+           "⦷" -> pure Mask+           "∊" -> pure Member+           "⊗" -> pure IndexOf+           "⟔" -> pure Coordinate+           "∵" -> pure Each+           "≡" -> pure Rows+           "⊞" -> pure Table+           "⍚" -> pure Inventory+           "⍥" -> pure Repeat+           "⍢" -> pure Do+           "/" -> pure Reduce+           "∧" -> pure Fold+           "\\" -> pure Scan+           "⊕" -> pure Group+           "⊜" -> pure Partition+           "°" -> pure Un+           "setinv" -> pure Setinv+           "setund" -> pure Setund+           "⍜" -> pure Under+           "◇" -> pure Content+           "⬚" -> pure Fill+           "⋕" -> pure Parse+           "⍣" -> pure Try+           "⍤" -> pure Assert+           "⚂" -> pure Random+           "_" -> pure Strand+           "[" -> pure ArrayLeft+           "]" -> pure ArrayRight+           "{" -> pure BoxArrayLeft+           "}" -> pure BoxArrayRight+           "(" -> pure FunctionLeft+           ")" -> pure FunctionRight+           "⟨" -> pure SwitchLeft+           "⟩" -> pure SwitchRight+           -- "¯" -> pure Negative+           "@" -> pure Character+           "$" -> pure Format+           "\"" -> pure String+           "!" -> pure Macro+           "^" -> pure Placeholder+           "←" -> pure Binding+           "↚" -> pure PrivateBinding+           "~" -> pure Import'+           "|" -> pure Signature+           "#" -> pure Comment+         |]+   )
+ src/Huihua/Parse/FlatParse.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Various <https://hackage.haskell.org/package/flatparse flatparse> helpers and combinators.+module Huihua.Parse.FlatParse+  ( -- * Parsing+    ParserWarning (..),+    runParserMaybe,+    runParserEither,+    runParserWarn,+    runParser_,++    -- * Flatparse re-exports+    runParser,+    Parser,+    Result (..),++    -- * Parsers+    isWhitespace,+    ws_,+    ws,+    wss,+    nota,+    isa,+    sq,+    dq,+    wrappedDq,+    wrappedSq,+    wrappedQ,+    wrappedQNoGuard,+    eq,+    sep,+    bracketed,+    bracketedSB,+    wrapped,+    digit,+    digits,+    int,+    double,+    minus,+    signed,+    byteStringOf',+    comma,+  )+where++import Data.Bool+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as B+import Data.Char hiding (isDigit)+import Data.These+import FlatParse.Basic hiding (cut, take)+import GHC.Exts+import GHC.Generics (Generic)+import Prelude hiding (replicate)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XOverloadedStrings+-- >>> import Huihua.Parse.FlatParse+-- >>> import FlatParse.Basic++-- | Run a Parser, throwing away leftovers. Nothing on 'Fail' or 'Err'.+--+-- >>> runParserMaybe ws "x"+-- Nothing+--+-- >>> runParserMaybe ws " x"+-- Just ' '+runParserMaybe :: Parser e a -> ByteString -> Maybe a+runParserMaybe p b = case runParser p b of+  OK r _ -> Just r+  Fail -> Nothing+  Err _ -> Nothing++-- | Run a Parser, throwing away leftovers. Returns Left on 'Fail' or 'Err'.+--+-- >>> runParserEither ws " x"+-- Right ' '+runParserEither :: (IsString e) => Parser e a -> ByteString -> Either e a+runParserEither p bs = case runParser p bs of+  Err e -> Left e+  OK a _ -> Right a+  Fail -> Left "uncaught parse error"++-- | Warnings covering leftovers, 'Err's and 'Fail'+--+-- >>> runParserWarn ws " x"+-- These (ParserLeftover "x") ' '+--+-- >>> runParserWarn ws "x"+-- This ParserUncaught+--+-- >>> runParserWarn (ws `cut` "no whitespace") "x"+-- This (ParserError "no whitespace")+data ParserWarning = ParserLeftover ByteString | ParserError ByteString | ParserUncaught deriving (Eq, Show, Ord, Generic)++-- | Run parser, returning leftovers and errors as 'ParserWarning's.+--+-- >>> runParserWarn ws " "+-- That ' '+--+-- >>> runParserWarn ws "x"+-- This ParserUncaught+--+-- >>> runParserWarn ws " x"+-- These (ParserLeftover "x") ' '+runParserWarn :: Parser ByteString a -> ByteString -> These ParserWarning a+runParserWarn p bs = case runParser p bs of+  Err e -> This (ParserError e)+  OK a "" -> That a+  OK a x -> These (ParserLeftover $ B.take 200 x) a+  Fail -> This ParserUncaught++-- | Run parser, discards leftovers & throws an error on failure.+--+-- >>> runParser_ ws " "+-- ' '+--+-- >>> runParser_ ws "x"+-- *** Exception: uncaught parse error+-- ...+runParser_ :: Parser String a -> ByteString -> a+runParser_ p bs = case runParser p bs of+  Err e -> error e+  OK a "" -> a+  OK _ _ -> error "leftovers"+  Fail -> error "uncaught parse error"++-- | Consume whitespace.+--+-- >>> runParser ws_ " \nx"+-- OK () "x"+--+-- >>> runParser ws_ "x"+-- OK () "x"+ws_ :: Parser e ()+ws_ =+  $( switch+       [|+         case _ of+           " " -> ws_+           "\n" -> ws_+           "\t" -> ws_+           "\r" -> ws_+           "\f" -> ws_+           _ -> pure ()+         |]+   )+{-# INLINE ws_ #-}++-- | \\n \\t \\f \\r and space+isWhitespace :: Char -> Bool+isWhitespace ' ' = True -- \x20 space+isWhitespace '\x0a' = True -- \n linefeed+isWhitespace '\x09' = True -- \t tab+isWhitespace '\x0c' = True -- \f formfeed+isWhitespace '\x0d' = True -- \r carriage return+isWhitespace _ = False+{-# INLINE isWhitespace #-}++-- | single whitespace+--+-- >>> runParser ws " \nx"+-- OK ' ' "\nx"+ws :: Parser e Char+ws = satisfy isWhitespace++-- | multiple whitespace+--+-- >>> runParser wss " \nx"+-- OK " \n" "x"+--+-- >>> runParser wss "x"+-- Fail+wss :: Parser e ByteString+wss = byteStringOf $ some ws++-- | Single quote+--+-- >>> runParserMaybe sq "'"+-- Just ()+sq :: ParserT st e ()+sq = $(char '\'')++-- | Double quote+--+-- >>> runParserMaybe dq "\""+-- Just ()+dq :: ParserT st e ()+dq = $(char '"')++-- | Parse whilst not a specific character+--+-- >>> runParser (nota 'x') "abcxyz"+-- OK "abc" "xyz"+nota :: Char -> Parser e ByteString+nota c = withSpan (skipMany (satisfy (/= c))) (\() s -> unsafeSpanToByteString s)+{-# INLINE nota #-}++-- | Parse whilst satisfying a predicate.+--+-- >>> runParser (isa (=='x')) "xxxabc"+-- OK "xxx" "abc"+isa :: (Char -> Bool) -> Parser e ByteString+isa p = withSpan (skipMany (satisfy p)) (\() s -> unsafeSpanToByteString s)+{-# INLINE isa #-}++-- | 'byteStringOf' but using withSpan internally. Doesn't seems faster...+byteStringOf' :: Parser e a -> Parser e ByteString+byteStringOf' p = withSpan p (\_ s -> unsafeSpanToByteString s)+{-# INLINE byteStringOf' #-}++-- | A single-quoted string.+wrappedSq :: Parser b ByteString+wrappedSq = $(char '\'') *> nota '\'' <* $(char '\'')+{-# INLINE wrappedSq #-}++-- | A double-quoted string.+wrappedDq :: Parser b ByteString+wrappedDq = $(char '"') *> nota '"' <* $(char '"')+{-# INLINE wrappedDq #-}++-- | A single-quoted or double-quoted string.+--+-- >>> runParserMaybe wrappedQ "\"quoted\""+-- Just "quoted"+--+-- >>> runParserMaybe wrappedQ "'quoted'"+-- Just "quoted"+wrappedQ :: Parser e ByteString+wrappedQ =+  wrappedDq+    <|> wrappedSq+{-# INLINE wrappedQ #-}++-- | A single-quoted or double-quoted wrapped parser.+--+-- >>> runParser (wrappedQNoGuard (many $ satisfy (/= '"'))) "\"name\""+-- OK "name" ""+--+-- Will consume quotes if the underlying parser does.+--+-- >>> runParser (wrappedQNoGuard (many anyChar)) "\"name\""+-- Fail+wrappedQNoGuard :: Parser e a -> Parser e a+wrappedQNoGuard p = wrapped dq p <|> wrapped sq p++-- | xml production [25]+--+-- >>> runParserMaybe eq " = "+-- Just ()+--+-- >>> runParserMaybe eq "="+-- Just ()+eq :: Parser e ()+eq = ws_ *> $(char '=') <* ws_+{-# INLINE eq #-}++-- | Some with a separator.+--+-- >>> runParser (sep ws (many (satisfy (/= ' ')))) "a b c"+-- OK ["a","b","c"] ""+sep :: Parser e s -> Parser e a -> Parser e [a]+sep s p = (:) <$> p <*> many (s *> p)++-- | Parser bracketed by two other parsers.+--+-- >>> runParser (bracketed ($(char '[')) ($(char ']')) (many (satisfy (/= ']')))) "[bracketed]"+-- OK "bracketed" ""+bracketed :: Parser e b -> Parser e b -> Parser e a -> Parser e a+bracketed o c p = o *> p <* c+{-# INLINE bracketed #-}++-- | Parser bracketed by square brackets.+--+-- >>> runParser bracketedSB "[bracketed]"+-- OK "bracketed" ""+bracketedSB :: Parser e [Char]+bracketedSB = bracketed $(char '[') $(char ']') (many (satisfy (/= ']')))++-- | Parser wrapped by another parser.+--+-- >>> runParser (wrapped ($(char '"')) (many (satisfy (/= '"')))) "\"wrapped\""+-- OK "wrapped" ""+wrapped :: Parser e () -> Parser e a -> Parser e a+wrapped x p = bracketed x x p+{-# INLINE wrapped #-}++-- | A single digit+--+-- >>> runParserMaybe digit "5"+-- Just 5+digit :: Parser e Int+digit = (\c -> ord c - ord '0') <$> satisfyAscii isDigit++-- | An (unsigned) 'Int' parser+--+-- >>> runParserMaybe int "567"+-- Just 567+int :: Parser e Int+int = do+  (place, n) <- chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0))+  case place of+    1 -> empty+    _ -> pure n++digits :: Parser e (Int, Int)+digits = do+  (place, n) <- chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0))+  case place of+    1 -> empty+    _ -> pure (place, n)++-- | A 'Double' parser. uiua does not parse .1 as a double.+--+-- >>> runParser double "1.234x"+-- OK 1.234 "x"+--+-- >>> runParser double "."+-- Fail+--+-- >>> runParser double "123"+-- OK 123.0 ""+--+-- >>> runParser double ".123"+-- Fail+--+-- >>> runParser double "123."+-- OK 123.0 "."+double :: Parser e Double+double = do+  (placel, nl) <- digits+  withOption+    ($(char '.') *> digits)+    ( \(placer, nr) ->+        case placel of+          1 -> empty+          _ -> pure $ fromIntegral nl + fromIntegral nr / fromIntegral placer+    )+    ( case placel of+        1 -> empty+        _ -> pure $ fromIntegral nl+    )++minus :: Parser e ()+minus = $(char '-') <|> byteString "¯"++-- | Parser for a signed prefix to a number. Unlike uiua, this parses '-' as a negative number prefix.+--+-- >>> runParser (signed double) "-1.234x"+-- OK (-1.234) "x"+--+-- >>> runParser (signed double) "¯1.234x"+-- OK (-1.234) "x"+signed :: (Num b) => Parser e b -> Parser e b+signed p = do+  m <- optional minus+  case m of+    Nothing -> p+    Just () -> negate <$> p++-- | Comma parser+--+-- >>> runParserMaybe comma ","+-- Just ()+comma :: Parser e ()+comma = $(char ',')
+ src/Huihua/Stack.hs view
@@ -0,0 +1,20 @@+module Huihua.Stack+  ( Stack (..),+  )+where++import Huihua.ArrayU+import Prettyprinter hiding (equals)+import Prelude++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Huihua.Stack as S+-- >>> import Harpie.Array as A++newtype Stack+  = Stack {stackList :: [ArrayU]}+  deriving (Show, Eq, Semigroup, Monoid)++instance Pretty Stack where+  pretty (Stack xs) = vsep (pretty <$> xs)
+ src/Huihua/Warning.hs view
@@ -0,0 +1,57 @@+module Huihua.Warning+  ( HuihuaWarning (..),+    showWarnings,+    Warn,+    warnError,+    warnEither,+    warnMaybe,+  )+where++import Control.Category ((>>>))+import Data.Bool+import Data.List qualified as List+import Data.These+import Prelude++data HuihuaWarning+  = HuihuaError String+  | NYI+  | EmptyStack1+  | EmptyStack2+  | ApplyFunction+  | NotBox+  | TypeMismatch+  | SizeMismatch+  | RankMismatch+  | NotNat+  | EmptyArray+  | NotArray+  | NoScalarOp+  | OutOfBounds+  | NoOpenArray+  | NotReduceable+  | ApplyNonOperator+  | RaggedInternal+  | NoIdentity+  | BadPick+  | BadTake+  deriving (Eq, Ord, Show)++showWarnings :: [HuihuaWarning] -> String+showWarnings = List.nub >>> fmap show >>> unlines++-- | A type synonym for the common returning type of many functions. A common computation pipeline is to take advantage of the 'These' Monad instance eg+type Warn a = These [HuihuaWarning] a++-- | Convert any warnings to an 'error'+warnError :: Warn a -> a+warnError = these (showWarnings >>> error) id (\xs a -> bool (error (showWarnings xs)) a (null xs))++-- | Returns Left on any warnings+warnEither :: Warn a -> Either [HuihuaWarning] a+warnEither = these Left Right (\xs a -> bool (Left xs) (Right a) (null xs))++-- | Returns results, if any, ignoring warnings.+warnMaybe :: Warn a -> Maybe a+warnMaybe = these (const Nothing) Just (\_ a -> Just a)
+ test/doctests.hs view
@@ -0,0 +1,8 @@+module Main where++import System.Environment (getArgs)+import Test.DocTest (mainFromCabal)+import Prelude (IO, (=<<))++main :: IO ()+main = mainFromCabal "huihua" =<< getArgs