path: root/Alpha.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Commonly useful functions, a Prelude replacement.
--
-- This is designed to be imported everywhere, unqualified (generally
-- the only unqualified import you should use).
--
-- Alpha can be opinionated and break with other Haskell idioms. For
-- example, we define our own operators which have a pattern to their
-- characters:
--
-- - `|` normal function-level applications
-- - `/` indicates doing something inside a functor
-- - `<` and `>` indicate the direction in which values flow
-- - `?` is for boolean tests or assertions
--   between functions
--
-- It seems unnecessarily different at first but it makes things easier
-- to read quickly.
--
-- Pronunciations are given for operators and are taken from
-- [Hoon](https://urbit.org/docs/tutorials/hoon/hoon-school/hoon-syntax/).
-- Pronouncing operators as you write the code is actually a nice way to
-- interact with the codebase, and I do recommend it.
module Alpha
  ( -- * Re-export Protolude
    module X,
    String,

    -- * Composing
    compose,
    (.>),
    (<.),

    -- * Applying
    (<|),
    (|>),

    -- * Mapping
    (/>),
    (</),
    (<%),
    (%>),

    -- * Binding
    bind,
    (+>),

    -- * Bool
    don't,
    (?>),
    (?<),
    (?:),
    (?.),
    (?+),

    -- * Text
    str,
    tshow,
    chomp,
    lchomp,
    CanSnakeCase (snake),
    wrap,

    -- * String
    capitalize,
    lowercase,
    strip,

    -- * Lists
    list,
    joinWith,

    -- * Data Validation
    require,
  )
where

import qualified Data.Char as Char
import qualified Data.List as List
import Data.String
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import Protolude as X hiding (list, ($), (&), (.), (>>=))
import Protolude.Conv
import qualified Prelude

-- | Create a list. This should be @Data.List.singleton@ but that doesn't exist.
list :: a -> [a]
list a = [a]

-- | Composition
compose :: (a -> b) -> (b -> c) -> (a -> c)
compose f g x = g (f x)

-- | Right-composition operator
--
-- Pronunciation: dot-gar
(.>) :: (a -> b) -> (b -> c) -> (a -> c)
f .> g = compose f g

-- | Left-composition operator
--
-- Pronunciation: gal-dot
(<.) :: (b -> c) -> (a -> b) -> (a -> c)
g <. f = compose f g

-- | Alias for map, fmap, <$>
--
-- Pronunciation: gal-fas
(</) :: Functor f => (a -> b) -> f a -> f b
f </ g = fmap f g

-- | Double fmap. A function on the right goes "into" two functors
-- (i.e. it goes "two levels deep"), applies the function to the inner
-- values, then returns the result wrapped in the two functors.
--
-- Pronunciation: gal-cen
(<%) :: (Functor f0, Functor f1) => (b -> a) -> f0 (f1 b) -> f0 (f1 a)
(<%) = fmap <. fmap

-- | Double fmap. A function on the left goes "into" two functors
-- (i.e. it goes "two levels deep"), applies the function to the inner
-- values, then returns the result wrapped in the two functors.
--
-- Pronunciation: cen-gar
(%>) :: (Functor f0, Functor f1) => (a -> b) -> f0 (f1 a) -> f0 (f1 b)
(%>) = fmap .> fmap

-- | Normal function application. Do the right side, then pass the
-- return value to the function on the left side.
--
-- Pronunciation: gal-bar
(<|) :: (a -> b) -> a -> b
f <| g = f g

infixr 1 <|

-- | Reverse function application. Do the left side, then pass the
-- return value to the function on the right side.
--
-- Pronunciation: bar-gar
(|>) :: a -> (a -> b) -> b
f |> g = g f

infixl 1 |>

-- | Alias for <&>. Can be read as "and then". Basically does into a
-- functor, does some computation, then returns the same kind of
-- functor. Could also be defined as `f +> return <. g`
--
-- Pronunciation: fas-gar
(/>) :: Functor f => f a -> (a -> b) -> f b
f /> g = fmap g f

infixl 1 />

bind :: Monad m => m a -> (a -> m b) -> m b
bind a f = a Prelude.>>= f

{- HLINT ignore "Use +>" -}

(+>) :: Monad m => m a -> (a -> m b) -> m b
a +> b = a Prelude.>>= b

infixl 1 +>

-- | If-then-else. wutcol
(?:) :: Bool -> (p, p) -> p
a ?: (b, c) = if a then b else c

-- | Inverted if-then-else. wutdot
(?.) :: Bool -> (p, p) -> p
a ?. (b, c) = if a then c else b

-- | Positive assertion. wutgar
(?>) :: Bool -> (Bool -> Text -> a) -> Text -> a
a ?> f = if a then f a else panic "wutgar failed"

-- | Lisp-style cond. wutlus
(?+) :: t -> [(t -> Bool, p)] -> p
a ?+ ((p, v) : ls) = if p a then v else a ?+ ls
_ ?+ [] = panic "wutlus: empty cond list"

-- | Negative assertion. wutgal
(?<) :: Bool -> (Bool -> Text -> a) -> Text -> a
a ?< f = if not a then f a else panic "wutgal failed"

-- | Removes newlinse from a string.
strip :: String -> String
strip = filter (/= '\n')

-- | Removes newlines from text.
chomp :: Text -> Text
chomp = Text.filter (/= '\n')

-- | Removes newlines from lazy text.
lchomp :: LazyText.Text -> LazyText.Text
lchomp = LazyText.filter (/= '\n')

-- | Join a list of things with a separator.
joinWith :: [a] -> [[a]] -> [a]
joinWith = intercalate

-- | can you just not
don't :: Bool -> Bool
don't = do not
{-# ANN don't ("HLint: ignore Redundant do" :: String) #-}

-- | Class for turning different string types to snakeCase.
class CanSnakeCase s where
  snake :: s -> s

instance CanSnakeCase Text where
  snake = Text.toLower .> Text.replace " " "-"

capitalize :: String -> String
capitalize [] = []
capitalize s = (Char.toUpper <| List.head s) : (Char.toLower </ List.tail s)

lowercase :: String -> String
lowercase s = [Char.toLower c | c <- s]

{-# WARNING require "'require' remains in code" #-}
require :: Text -> Maybe a -> a
require _ (Just x) = x
require s Nothing = panic <| s <> " not found"

-- | Wrap text at the given limit.
wrap :: Int -> Text -> Text
wrap lim = Text.words .> wrap_ 0 .> Text.unwords
  where
    wrap_ :: Int -> [Text] -> [Text]
    wrap_ _ [] = []
    wrap_ pos (w : ws)
      | pos == 0 = w : wrap_ (pos + lw) ws
      | pos + lw + 1 > lim = wrap_ 0 (Text.cons '\n' w : ws)
      | otherwise = w : wrap_ (pos + lw + 1) ws
      where
        lw = Text.length w

str :: (StringConv a b) => a -> b
str = Protolude.Conv.toS

tshow :: Show a => a -> Text
tshow = show