Wow

Scott.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

module Scott where

import qualified Prelude as Builtin
import qualified Data.Char as Builtin
import GHC.Num (Num(fromInteger, (-), (+)))
import Data.String (IsString(fromString))

(.) :: (b -> c) -> (a -> b) -> a -> c
(f . g) a = f (g a)

flip :: (a -> b -> c) -> b -> a -> c
flip f b a = f a b

($) :: (a -> b) -> a -> b
f $ a = f a

newtype Pair a b
  = Pair (forall c. (a -> b -> c) -> c)

pair :: a -> b -> Pair a b
pair a b = Pair (\g -> g a b)

fst :: Pair a b -> a
fst (Pair p) = p (\a _ -> a)

snd :: Pair a b -> b
snd (Pair p) = p (\_ b -> b)

newtype Bool
  = Bool (forall c. c -> c -> c)

true :: Bool
true = Bool (\t _ -> t)

false :: Bool
false = Bool (\_ f -> f)

bool :: a -> a -> Bool -> a
bool f t (Bool b) = b t f

fromBuiltIn :: Builtin.Bool -> Bool
fromBuiltIn Builtin.True = true
fromBuiltIn Builtin.False = false

toBuiltin :: Bool -> Builtin.Bool
toBuiltin = bool Builtin.False Builtin.True

ifThenElse :: Bool -> a -> a -> a
ifThenElse b t f = bool f t b

(&&) :: Bool -> Bool -> Bool
a && b = bool a b a

(||) :: Bool -> Bool -> Bool
a || b = bool b a a

class Eq a where
  (==) :: a -> a -> Bool

instance Eq Builtin.Integer where
  a == b = fromBuiltIn (a Builtin.== b)

newtype Maybe a
  = Maybe (forall c. c -> (a -> c) -> c)

nothing :: Maybe a
nothing = Maybe (\n _ -> n)

just :: a -> Maybe a
just a = Maybe (\_ j -> j a)

maybe :: b -> (a -> b) -> Maybe a -> b
maybe b a2b (Maybe m) = m b a2b

class Functor f where
  (<$>) :: (a -> b) -> f a -> f b

class Functor f => Applicative f where
  pure :: a -> f a
  (<*>) :: f (a -> b) -> f a -> f b

class Applicative f => Monad f where
  return :: a -> f a
  return = pure

  (=<<) :: (a -> f b) -> f a -> f b

  (>>=) :: f a -> (a -> f b) -> f b
  (>>=) = flip (=<<)

instance Functor Maybe where
  (<$>) f = maybe nothing (just . f)

instance Applicative Maybe where
  pure = just
  ma2b <*> ma =
    maybe nothing (<$> ma) ma2b

instance Monad Maybe where
  ma2mb =<< ma =
    maybe nothing ma2mb ma

newtype Nat
  = Nat (forall c. c -> (Nat -> c) -> c)

zero :: Nat
zero = Nat (\z _ -> z)

succ :: Nat -> Nat
succ n = Nat (\_ s -> s n)

foldNat :: (a -> a) -> a -> Nat -> a
foldNat f a (Nat n) = n a (foldNat f (f a))

toIntegral :: Builtin.Integral a => Nat -> a
toIntegral = foldNat (+ 1) 0

unFoldNat :: (a -> Maybe a) -> a -> Nat
unFoldNat f a = maybe zero (succ . unFoldNat f) (f a)

fromIntegral :: (Builtin.Integral a, Eq a) => a -> Nat
fromIntegral =
  unFoldNat
    (\n ->
       if n == 0
         then nothing
         else just (n - 1)) .
  Builtin.max 0

instance Eq Nat where
  Nat a == Nat b = a (b true (\_ -> false)) (\a' -> b false (== a'))

instance Eq Builtin.Int where
  a == b = fromBuiltIn (a Builtin.== b)

newtype Char = Char Nat

fromBuiltInChar :: Builtin.Char -> Char
fromBuiltInChar = Char . fromIntegral . Builtin.ord

toBuiltInChar :: Char -> Builtin.Char
toBuiltInChar (Char c) = Builtin.chr (toIntegral c)

instance Eq Char where
  Char a == Char b = a == b

class Show a where
  show :: a -> String

instance Show Char where
  show c = "'" <> String (cons c nil) <> "'"

newtype List a
  = List (forall c. c -> (a -> List a -> c) -> c)

nil :: List a
nil = List (\n _ -> n)

cons :: a -> List a -> List a
cons a as = List (\_ c -> c a as)

uncons :: List a -> Maybe (Pair a (List a))
uncons (List l) =
  l nothing (\a as -> just (pair a as))

foldr :: (a -> b -> b) -> b -> List a -> b
foldr f b (List l) =
  l b (\a as -> f a (foldr f b as))

class Semigroup a where
  (<>) :: a -> a -> a

instance Semigroup (List a) where
  a <> b = foldr cons b a

instance Builtin.Show a => Builtin.Show (List a) where
  show = Builtin.show . foldr (:) []

newtype String = String { asList :: List Char }

instance Semigroup String where
  String a <> String b = String (a <> b)

instance IsString String where
  fromString = String . Builtin.foldr (cons . fromBuiltInChar) nil

instance Show String where
  show s = "\"" <> s <> "\""

instance Builtin.Show String where
  show = foldr ((:) . toBuiltInChar) [] . asList

newtype Parser a =
  Parser (String -> Maybe (Pair a String))

parse :: Parser a -> String -> Maybe (Pair a String)
parse (Parser parser) = parser

instance Functor Parser where
  a2b <$> Parser pa =
    Parser
      ((<$>) (\p -> pair (a2b (fst p)) (snd p)) . pa)

instance Applicative Parser where
  pure a = Parser (just . pair a)

  Parser pa2b <*> pa =
    Parser $ \str -> do
      p <- pa2b str
      parse ((<$>) (fst p) pa) (snd p)

instance Monad Parser where
  a2pb =<< Parser pa =
    Parser $ \str -> do
      p <- pa str
      parse (a2pb (fst p)) (snd p)

satisfy :: (Char -> Bool) -> Parser Char
satisfy predicate =
  Parser $ \(String l) -> do
    p <- uncons l
    let c = fst p
        rest = String (snd p)
    if predicate c
      then just (pair c rest)
      else nothing

is :: Char -> Parser Char
is = satisfy . (==)

instance Show a => Show (Maybe a) where
  show = maybe "Nothing" (\a -> "Just " <> show a)

instance Show a => Builtin.Show (Maybe a) where
  show = Builtin.show . show

instance (Show a, Show b) => Show (Pair a b) where
  show p = "(" <> show (fst p) <> "," <> show (snd p) <> ")"

-- | Try it out
--
-- >>> :set -XOverloadedStrings
-- >>> input = "abc" :: String
-- >>> a = fromBuiltInChar 'a'
-- >>> b = fromBuiltInChar 'b'
-- >>> c = fromBuiltInChar 'c'
-- >>> x = fromBuiltInChar 'x'
-- >>> parse (is a) input
-- Just ('a',"bc")
-- >>> parse (pair <$> is a <*> is b) input
-- Just (('a','b'),"c")
-- >>> parse (pair <$> is x <*> is b) input
-- Nothing