Move stuff around + add lean and idris experiments

purescript/typelevel/src/Ast.purs

@@ -0,0 +1,256 @@
+-- | Lambda calculus ast
+module Ast where
+
+
+import Data.Symbol (SProxy(..))
+import Num (class NAreEqual, NProxy(..), Succ, Zero, kind Num)
+import Num as Nat
+import Ordering (class OrdsAreEqual)
+import Prim.Boolean (False, True, kind Boolean)
+import Prim.Ordering (GT, LT, kind Ordering)
+import Prim.Symbol (class Append, class Compare, class Cons)
+import Type.Data.Boolean (class And, class If, class Not)
+
+foreign import kind Ast
+foreign import data Var :: Symbol -> Ast
+foreign import data Call :: Ast -> Ast -> Ast
+foreign import data Lambda :: Symbol -> Ast -> Ast
+
+foreign import kind Left 
+foreign import kind Right
+
+foreign import kind Either
+foreign import data Left :: Symbol -> Either
+foreign import data Right :: Right -> Either
+
+foreign import data RightUnit_ :: Right
+foreign import data RightSymbol_ :: Symbol -> Right
+foreign import data RightAst :: Ast -> Right
+
+type RightSymbol a = Right (RightSymbol_ a)
+type RightUnit = Right RightUnit_
+
+foreign import kind ParsingResult
+foreign import data ParsingResult :: Either -> Symbol -> ParsingResult
+
+data PRProxy (a :: ParsingResult) = PRProxy
+data EProxy (a :: Either) = EProxy
+
+-------------- Typeclasses
+-- Conditionals
+class EIf (bool :: Boolean)
+    (onTrue :: Either)
+    (onFalse :: Either)
+    (output :: Either) 
+    | bool onTrue onFalse -> output
+
+instance eifTrue :: EIf True onTrue onFalse onTrue
+instance eifFalse :: EIf False onTrue onFalse onFalse
+
+-- Merge 2 eithers
+class MergeEithers (a :: Either) (b :: Either) (c :: Either) | a b -> c
+
+instance mergeEithersLeft :: MergeEithers (Left err) right (Left err)
+else instance mergeEithersLeft' :: MergeEithers left (Left err) (Left err)
+else instance mergeEithersRight :: MergeEithers left right right
+
+-- Check if 2 symbols are equal
+class SymbolsAreEqual (a :: Symbol) (b :: Symbol) (result :: Boolean) | a b -> result
+
+instance saeT :: SymbolsAreEqual a a True
+else instance saeF :: SymbolsAreEqual a b False
+
+-- Measure length of string
+class Length (input :: Symbol) (output :: Num) | input -> output
+
+instance lengthEmpty :: Length "" Zero
+else instance lengthCons ::
+    ( Cons head tail input
+    , Length tail length
+    ) => Length input (Succ length)
+
+-- Actual parsing
+class ParseAst (input :: Symbol) (result :: Ast) | input -> result
+
+-- Parses a literal thing.
+class ParseLiteral (lit :: Symbol) (input :: Symbol) (result :: ParsingResult) | lit input -> result
+
+instance parseLiteralGeneral' ::
+    ( Length literal litLength
+    , Length input inputLength
+    , Nat.Compare inputLength litLength ord
+    , ParseLiteralEnsureCorrectLength ord literal input result 
+    ) => ParseLiteral literal input result
+
+class ParseLiteralEnsureCorrectLength (ord :: Ordering) (lit :: Symbol) (input :: Symbol) (result :: ParsingResult) | ord lit input -> result
+
+instance parseLiteralEnsureCorrectLengthLT ::
+    Append "Not enough input text to match literal " literal error 
+    => ParseLiteralEnsureCorrectLength LT literal input (ParsingResult (Left error) input)
+else instance parseLitealEnsureCorrectLengthGeneral ::
+    ParseLiteral' literal input result 
+    => ParseLiteralEnsureCorrectLength ord literal input result
+
+class ParseLiteral' (lit :: Symbol) (input :: Symbol) (result :: ParsingResult) | lit input -> result
+
+instance parseLiteralEmpty :: ParseLiteral' "" input (ParsingResult (Right RightUnit_) input)
+else instance parseLiteralGeneral ::
+    ( Cons litHead litTail literal
+    , Cons litInput inputTail input
+    , SymbolsAreEqual litHead litInput areEqual
+    , Append "Expected " litHead error
+    , EIf areEqual RightUnit (Left error) result
+    , ParseLiteral' litTail inputTail (ParsingResult result' remaining)
+    , MergeEithers result result' result''
+    ) => ParseLiteral' literal input (ParsingResult result'' remaining)
+
+-- Skips whitespace
+class SkipWhitespace (input :: Symbol) (result :: Symbol) | input -> result
+
+instance skipWhitespaceEmpty :: SkipWhitespace "" ""
+else instance skipWhitespaceNonEmpty ::
+    ( Cons head tail input
+    , SymbolsAreEqual head " " equal
+    , SkipWhitespace tail tailResult
+    , If equal (SProxy tailResult) (SProxy input) (SProxy result)
+    ) => SkipWhitespace input result 
+
+-- Lambda parsing
+class ParseLambda (input :: Symbol) (result :: ParsingResult) | input -> result
+
+instance parseLambdaGeneral ::
+    ( ParseLiteral "\\" input (ParsingResult either remaining)
+    , SkipWhitespace remaining remaining'
+    , ParseIdentifier remaining' (ParsingResult arg remaining'')
+    , SkipWhitespace remaining'' remaining'''
+    , ParseLiteral "." remaining''' (ParsingResult either' remaining'''')
+    , SkipWhitespace remaining'''' remaining'''''
+    , ParseIdentifier remaining''''' (ParsingResult body remaining'''''')
+    , MergeEithers either either' mergedEither
+    , MergeEithers arg body mergedEither'
+    , MergeEithers mergedEither mergedEither' mergedEither''
+    , ParseLambda' mergedEither'' arg body remaining'''''' result
+    ) => ParseLambda input result
+
+class ParseLambda' 
+    (either :: Either) 
+    (arg :: Either) 
+    (body :: Either) 
+    (input :: Symbol) 
+    (result :: ParsingResult) 
+    | either input -> result
+
+instance parseLambda'Left :: ParseLambda' (Left left) arg body remaining (ParsingResult (Left left) remaining)
+else instance parseLambda'Right :: 
+    ParseLambda' 
+        right 
+        (Right (RightSymbol_ arg)) 
+        (Right (RightSymbol_ body)) 
+        remaining
+        (ParsingResult (Right (RightAst (Lambda arg (Var body)))) remaining)
+
+-- Parses a single alphabetic character
+class IsAlphaChar (input :: Symbol) (result :: Boolean) | input -> result
+
+instance isAlphaChar ::
+    ( Compare "@" input a
+    , Compare "{" input b
+    , OrdsAreEqual a LT a'
+    , OrdsAreEqual b GT b'
+    , And a' b' result
+    ) => IsAlphaChar input result
+
+-- Parses a single identifier
+class ParseIdentifier (input :: Symbol) (result :: ParsingResult) | input -> result
+
+instance parseIdentifierEnsureCorrectLength ::
+    ( ParseIdentifier' input result remaining
+    , Length result resultLength
+    , NAreEqual resultLength Zero empty
+    , Not empty success
+    , EIf empty (Left "Empty identifier") (RightSymbol result) result'
+     ) => ParseIdentifier input (ParsingResult result' remaining)
+
+class ParseIdentifier' (input :: Symbol) (result :: Symbol) (remaining :: Symbol) | input -> result remaining
+
+instance parseIdentifierGeneral :: 
+    ( IsAlphaChar input good
+    , ParseIdentifier'' good input result remaining
+    ) => ParseIdentifier' input result remaining
+
+class ParseIdentifier'' 
+    (goodFirstChar :: Boolean) 
+    (input :: Symbol) 
+    (result :: Symbol) 
+    (remaining :: Symbol) | goodFirstChar input -> result remaining
+
+instance parseIdentifierGood :: 
+    ( Cons head remaining input
+    , ParseIdentifier' remaining tail remaining'
+    , Append head tail result 
+    ) => ParseIdentifier'' True input result remaining'
+else instance parseIdentifierBad :: ParseIdentifier'' False input "" input
+
+-- Helpers
+length :: forall s n. Length s n => SProxy s -> NProxy n
+length _ = NProxy
+
+parseIdentifier :: 
+    forall input result. 
+    ParseIdentifier input result => 
+    SProxy input -> 
+    PRProxy result
+parseIdentifier _ = PRProxy
+
+parseLambda :: 
+    forall input result.
+    ParseLambda input result =>
+    SProxy input ->
+    PRProxy result
+parseLambda _ = PRProxy
+
+parseLiteral :: 
+    forall literal input result.
+    ParseLiteral literal input result =>
+    SProxy literal ->
+    SProxy input ->
+    PRProxy result
+parseLiteral _ _ = PRProxy
+
+-- Tests
+-- Parse identifier
+a :: PRProxy (ParsingResult (Left "Empty identifier") "")
+a = parseIdentifier (SProxy :: SProxy "")
+
+b :: PRProxy (ParsingResult (Right (RightSymbol_ "abc")) "")
+b = parseIdentifier (SProxy :: SProxy "abc")
+
+c :: PRProxy (ParsingResult (Right (RightSymbol_ "abc")) " something else CAPS")
+c = parseIdentifier (SProxy :: SProxy "abc something else CAPS")
+
+d :: PRProxy (ParsingResult (Left "Empty identifier") "     doesn\'t automatically skip whitespace")
+d = parseIdentifier (SProxy :: SProxy "     doesn't automatically skip whitespace")
+
+-- Parsing literals
+lit :: PRProxy (ParsingResult (Right RightUnit_) " hmmmm!!!")
+lit = parseLiteral (SProxy :: SProxy "something") (SProxy :: SProxy "something hmmmm!!!")
+
+lit' :: PRProxy (ParsingResult (Left "Expected s") "ing hmmmm!!!")
+lit' = parseLiteral (SProxy :: SProxy "something") (SProxy :: SProxy "   something hmmmm!!!")
+
+lit'' :: PRProxy (ParsingResult (Left "Not enough input text to match literal something") "someth")
+lit'' = parseLiteral (SProxy :: SProxy "something") (SProxy :: SProxy "someth")
+
+lit''' :: PRProxy (ParsingResult (Left "Expected e") "g hmmm")
+lit''' = parseLiteral (SProxy :: SProxy "something") (SProxy :: SProxy "somnething hmmm")
+
+lit'''' :: PRProxy (ParsingResult (Left "Expected s") "mmm")
+lit'''' = parseLiteral (SProxy :: SProxy "something") (SProxy :: SProxy "zomethi hmmm")
+
+-- Lambda parsing
+lam :: PRProxy (ParsingResult (Right (RightAst (Lambda "a" (Var "a")))) "")
+lam = parseLambda (SProxy :: SProxy "\\a. a")
+
+-- Lenghts
+lengthTest :: NProxy (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))
+lengthTest = length (SProxy :: SProxy "Adriel")

purescript/typelevel/src/Fin.purs

@@ -0,0 +1,69 @@
+module Data.Fin where
+
+import Prelude
+
+import Data.Leibniz (type (~), coerce, liftLeibniz, liftLeibniz1of2, lowerLeibniz, refute, symm)
+import Type.Proxy (Proxy)
+import Unsafe.Coerce (unsafeCoerce)
+
+data Nat
+
+foreign import data Z :: Nat
+foreign import data S :: Nat -> Nat
+
+foreign import data Add :: Nat -> Nat -> Nat
+
+addZ :: forall a. Add Z a ~ a
+addZ = unsafeCoerce \u -> u
+
+addS :: forall a b. Add (S a) b ~ S (Add a b)
+addS = unsafeCoerce \u -> u
+
+data Vec s a
+  = Nil (s ~ Z)
+  | Cons a (forall r. (forall p. S p ~ s -> Vec p a -> r) -> r)
+
+nil :: forall a. Vec Z a
+nil = Nil identity
+
+cons :: forall a n. a -> Vec n a -> Vec (S n) a
+cons head tail = Cons head \f -> f identity tail
+
+data Fin n
+  = FZ (forall r. (forall p. S p ~ n -> r) -> r)
+  | FS (forall r. (forall p. S p ~ n -> Fin p -> r) -> r)
+
+fz :: forall n. Fin (S n)
+fz = FZ \f -> f identity
+
+fs :: forall n. Fin n -> Fin (S n)
+fs p = FS \f -> f identity p
+
+refuteFinZero :: Fin Z -> Void
+refuteFinZero (FZ oops) = oops \eq -> refute (liftLeibniz eq :: Proxy _ ~ Proxy _)
+refuteFinZero (FS oops) = oops \eq _ -> refute (liftLeibniz eq :: Proxy _ ~ Proxy _)
+
+succInj :: forall a b. S a ~ S b -> a ~ b
+succInj = lowerLeibniz
+
+lookup :: forall l a. Vec l a -> Fin l -> a
+lookup (Cons a _) (FZ _) = a
+lookup (Cons _ nextVec) (FS nextFin) =
+  nextFin \eq finP ->
+    nextVec \eq' vecP -> do
+      let trans = liftLeibniz (succInj (eq >>> symm eq'))
+      lookup vecP (coerce trans finP)
+lookup (Nil lenIsZero) fin = absurd $ refuteFinZero (coerce finIsFinZero fin)
+  where
+  finIsFinZero :: Fin l ~ Fin Z
+  finIsFinZero = liftLeibniz lenIsZero
+
+concat :: forall n m a. Vec n a -> Vec m a -> Vec (Add n m) a
+concat (Nil nIsZ) other = coerce
+  (liftLeibniz1of2 (symm addZ >>> liftLeibniz1of2 (symm nIsZ)))
+  other
+concat (Cons e nextVec) other = nextVec \eq vecP -> do
+  coerce
+    (liftLeibniz1of2 (symm addS >>> liftLeibniz1of2 eq))
+    (cons e (concat vecP other))
+

purescript/typelevel/src/Main.purs

@@ -0,0 +1,10 @@
+module Main where
+
+import Prelude
+
+import Effect (Effect)
+import Effect.Console (log)
+
+main :: Effect Unit
+main = do
+  log "🍝"

purescript/typelevel/src/Num.purs

@@ -0,0 +1,251 @@
+module Num where
+
+import Data.Symbol (SProxy(..))
+import Data.Unit (Unit, unit)
+import Prim.Boolean (False, True, kind Boolean)
+import Prim.Ordering (EQ, GT, LT, kind Ordering)
+import Prim.Symbol (class Cons)
+
+foreign import kind Num
+
+foreign import data Zero :: Num
+foreign import data Succ :: Num -> Num
+
+data NProxy (i :: Num)
+  = NProxy
+
+-- Predecessor
+class Pred (input :: Num) (output :: Num) | input -> output, output -> input
+
+instance predSucc :: Pred (Succ a) a
+
+-- Conditionals
+class NumIf 
+  (bool :: Boolean)
+  (onTrue :: Num)
+  (onFalse :: Num)
+  (output :: Num) 
+  | bool onTrue onFalse -> output
+
+instance ifTrue :: NumIf True onTrue onFalse onTrue
+instance ifFalse :: NumIf False onTrue onFalse onFalse
+
+-- Addition
+class Add (a :: Num) (b :: Num) (output :: Num) 
+  | a b -> output
+  , a output -> b
+
+instance addZero :: Add Zero a a
+else instance addSucc :: Add a b c => Add (Succ a) b (Succ c)
+
+-- Substraction 
+class Sub (a :: Num) (b :: Num) (output :: Num) 
+  | a b -> output
+  , b output -> a
+
+instance subZero :: Sub a Zero a
+else instance subSucc :: Sub a b c => Sub (Succ a) (Succ b) c
+
+-- Multiplication 
+class Multiply (a :: Num) (b :: Num) (output :: Num) 
+  | a b -> output
+
+instance multiplyZero :: Multiply Zero a Zero
+else instance multiplySucc :: (Multiply a b c, Add b c result) => Multiply (Succ a) b result
+
+-- Division
+class Divide'
+  (a :: Num) 
+  (b :: Num) 
+  (result :: Num) 
+  (mod :: Num) 
+  (ord :: Ordering)
+  | a b ord -> result mod
+
+instance divideZero :: Divide' Zero a Zero Zero LT
+else instance divideMod :: Divide' a b Zero a LT
+else instance divideSucc :: (Divide a b result mod, Sub a' b a) => Divide' a' b (Succ result) mod ord
+
+class Divide 
+  (a :: Num) 
+  (b :: Num) 
+  (result :: Num) 
+  (mod :: Num) 
+  | a b -> result mod
+
+instance divideAndCompare :: (Compare a b ord, Divide' a b result mod ord) => Divide a b result mod
+
+-- Raising to power
+class Pow (base :: Num) (power :: Num) (output :: Num) 
+  | base power -> output
+  -- Does this work?
+  -- , power output -> base
+
+instance powZero :: Pow Zero a (Succ Zero) 
+else instance powOne :: Pow a (Succ Zero) a
+else instance powSucc :: (Pow a b c, Multiply c a result) => Pow a (Succ b) result 
+
+-- Equality checking 
+class NAreEqual (a :: Num) (b :: Num) (result :: Boolean) | a b -> result
+
+instance areEqualZero :: NAreEqual Zero Zero True
+else instance areEqualSucc :: NAreEqual a b c => NAreEqual (Succ a) (Succ b) c
+else instance areNotEqual :: NAreEqual a b False
+
+class Factorial (input :: Num) (output :: Num) | input -> output
+
+instance factorialZero :: Factorial Zero (Succ Zero)
+instance factorialSucc :: (Factorial a a', Multiply a' (Succ a) result) => Factorial (Succ a) result
+
+-- Ordering
+class Compare (a :: Num) (b :: Num) (output :: Ordering) 
+  | a b -> output
+
+instance compareEqual :: Compare Zero Zero EQ
+else instance compareZeroLower :: Compare Zero a LT
+else instance compareZeroGreater :: Compare a Zero GT
+else instance compareSucc :: Compare a b c => Compare (Succ a) (Succ b) c
+
+-- Parsing
+class ParseNum (input :: Symbol) (output :: Num) | input -> output
+
+instance parseNum :: (Cons head tail input, ParseNum' head tail output) => ParseNum input output
+
+class ParseNum' (head :: Symbol) (tail :: Symbol) (output :: Num) | head tail -> output
+
+instance parseNumSingle :: ParseDigit input result => ParseNum' input "" result
+else instance parseNumHeadTail :: 
+  ( ParseDigit head resultHead
+  , ParseNum tail resultTail
+  , Multiply resultHead (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))))) result' 
+  , Add result' resultTail result )
+    => ParseNum' head tail result
+
+class ParseDigit (input :: Symbol) (output :: Num) | input -> output, output -> input
+
+instance parseDigit0 :: ParseDigit "0" Zero
+instance parseDigit1 :: ParseDigit "1" (Succ Zero)
+instance parseDigit2 :: ParseDigit "2" (Succ (Succ Zero))
+instance parseDigit3 :: ParseDigit "3" (Succ (Succ (Succ Zero)))
+instance parseDigit4 :: ParseDigit "4" (Succ (Succ (Succ (Succ Zero))))
+instance parseDigit5 :: ParseDigit "5" (Succ (Succ (Succ (Succ (Succ Zero)))))
+instance parseDigit6 :: ParseDigit "6" (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))
+instance parseDigit7 :: ParseDigit "7" (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))
+instance parseDigit8 :: ParseDigit "8" (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))))
+instance parseDigit9 :: ParseDigit "9" (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))))
+
+-- Constructors
+zero :: NProxy Zero
+zero = NProxy
+
+succ :: forall a. NProxy a -> NProxy (Succ a)
+succ _ = NProxy
+
+pred :: forall i o. Pred i o => NProxy i -> NProxy o
+pred _ = NProxy
+
+add :: forall a b c. Add a b c => NProxy a -> NProxy b -> NProxy c
+add _ _ = NProxy
+
+sub :: forall a b c. Sub a b c => NProxy a -> NProxy b -> NProxy c
+sub _ _ = NProxy
+
+multiply :: forall a b c. Multiply a b c => NProxy a -> NProxy b -> NProxy c
+multiply _ _ = NProxy
+
+pow :: forall a b c. Pow a b c => NProxy a -> NProxy b -> NProxy c
+pow _ _  = NProxy 
+
+divide ::forall a b c d. Divide a b c d => NProxy a -> NProxy b -> { result :: NProxy c, mod :: NProxy d }
+divide _ _  = { mod: NProxy, result: NProxy }
+
+div :: forall a b c d. Divide a b c d => NProxy a -> NProxy b -> NProxy c
+div _ _  = NProxy
+
+mod :: forall a b c d. Divide a b c d => NProxy a -> NProxy b -> NProxy d
+mod _ _  = NProxy
+
+parse :: forall a n. ParseNum a n => SProxy a -> NProxy n
+parse _ = NProxy
+
+equal :: forall a b. NAreEqual a b True => NProxy a -> NProxy b -> Unit
+equal _ _ = unit
+
+factorial :: forall a b. Factorial a b => NProxy a -> NProxy b
+factorial _ = NProxy
+
+-- Basic values
+type One = Succ Zero
+type Two = Succ One
+type Three = Succ Two
+type Four = Succ Three
+type Five = Succ Four
+type Six = Succ Five
+type Seven = Succ Six
+type Eight = Succ Seven
+type Nine = Succ Eight
+type Ten = Succ Nine
+
+-- Tests
+one :: NProxy One
+one = succ zero
+
+two :: NProxy Two
+two = succ one
+
+three :: NProxy Three
+three = succ two
+
+five :: NProxy (Succ (Succ (Succ (Succ (Succ Zero)))))
+five = add two three
+
+-- Solvable when the first param is missing
+two' :: NProxy Two
+two' = sub five three
+
+six :: NProxy (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))
+six = multiply three two
+
+fifteen :: NProxy (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))
+fifteen = multiply three two
+
+eight :: NProxy (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))))
+eight = pow two three
+
+one' :: NProxy (Succ Zero)
+one' = pow zero three
+
+four :: NProxy (Succ Three)
+four = succ three
+
+five' :: NProxy (Succ (Succ (Succ (Succ Zero))))
+five' = pow two two
+ where
+ _25 = add two (add eight fifteen)
+
+sixDivThree :: NProxy (Succ (Succ Zero))
+sixDivThree = div six three
+
+sevenDivThree :: 
+  { mod :: NProxy (Succ Zero)
+  , result :: NProxy (Succ (Succ Zero))
+  }
+sevenDivThree = divide (succ six) three
+
+parse13 :: NProxy (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))))))))
+parse13 = parse _13
+  where
+  _13 :: SProxy "13"
+  _13 = SProxy
+
+parse64 :: Unit
+parse64 = equal (parse _64) (pow two six)
+  where
+  _64 :: SProxy "64"
+  _64 = SProxy
+
+fac3 :: NProxy (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))
+fac3 = factorial (parse _3)
+  where
+  _3 :: SProxy "3"
+  _3 = SProxy

purescript/typelevel/src/Ordering.purs

@@ -0,0 +1,10 @@
+module Ordering where
+
+import Prim.Boolean (False, True, kind Boolean)
+import Prim.Ordering (kind Ordering)
+
+-- Compare 2 orderings
+class OrdsAreEqual (a :: Ordering) (b :: Ordering) (result :: Boolean) | a b -> result
+
+instance oaeGT :: OrdsAreEqual a a True
+else instance oaeGeneral :: OrdsAreEqual a b False

purescript/typelevel/src/Term.purs

@@ -0,0 +1,299 @@
+module Term where
+
+import Num (class Add, class Compare, class NAreEqual, class Sub, NProxy, Succ, Zero, five, four, one, three, two, zero, kind Num)
+import Prim.Boolean (False, True, kind Boolean)
+import Prim.Ordering (GT, kind Ordering)
+import Type.Data.Boolean (class And, class Or, BProxy(..))
+
+foreign import kind Term
+foreign import data Var :: Num -> Term
+foreign import data Abstraction :: Term -> Term
+foreign import data Application :: Term -> Term -> Term 
+
+-- Reduce
+class Reduce (input :: Term) (output :: Term) | input -> output
+
+instance reduceGeneral :: 
+    ( BetaReduce a b 
+    , EtaReduce b c 
+    ) => Reduce a c
+
+-- Checking if an expression references a variable
+class HasReference (term :: Term) (index :: Num) (output :: Boolean) | term index -> output
+
+instance hasReferenceVar :: 
+    NAreEqual index var result 
+    => HasReference (Var var) index result
+else instance hasReferenceCall :: 
+    (HasReference left index leftResult
+    , HasReference right index rightResult
+    , Or leftResult rightResult result
+    ) => HasReference (Application left right) index result 
+else instance hasReferenceAbstraction :: 
+    HasReference term (Succ index) result 
+    => HasReference (Abstraction term) index result
+
+-- Shifting
+class ShiftTerm 
+    (term :: Term) 
+    (over :: Num) 
+    (direction :: Boolean)
+    (amount :: Num)
+    (result :: Term) 
+    | term over direction amount -> result
+
+instance shiftTermApplication ::
+    ( ShiftTerm left over sign amount leftResult
+    , ShiftTerm right over sign amount rightResult )
+    => ShiftTerm (Application left right) over sign amount (Application leftResult rightResult)
+else instance shiftTermAbstraction ::
+    ShiftTerm term (Succ over) sign amount result
+    => ShiftTerm (Abstraction term) over sign amount (Abstraction result)
+else instance shiftTermVar :: 
+    ( Compare (Succ index) over ord
+    , ShiftVar ord index sign amount result )
+    => ShiftTerm (Var index) over sign amount (Var result) 
+
+class ShiftVar 
+    (ord :: Ordering) 
+    (index :: Num) 
+    (sign :: Boolean)
+    (amount :: Num) 
+    (result :: Num) 
+    | index sign amount ord -> result
+
+instance shiftVarGTPositive :: 
+    Add index amount result
+    => ShiftVar GT index True amount result
+else instance shiftVarGTNegative :: 
+    Sub index amount result
+    => ShiftVar GT index False amount result
+else instance shiftVarGeneral :: ShiftVar ord index sign amount index
+
+-- Equality 
+class TermsAreEqual (a :: Term) (b :: Term) (result :: Boolean) | a b -> result
+
+instance termsAreEqualVar :: NAreEqual a b result => TermsAreEqual (Var a) (Var b) result
+else instance termsAreEqualAbstraction :: TermsAreEqual a b result => TermsAreEqual (Abstraction a) (Abstraction b) result
+else instance termsAreEqualApplication :: 
+    ( TermsAreEqual left left' leftResult 
+    , TermsAreEqual right right' rightResult
+    , And leftResult rightResult result )
+    => TermsAreEqual (Application left right) (Application left' right') result
+else instance termsAreEqualGeneral :: TermsAreEqual a b False
+
+-- Eta reduction
+class EtaReduceAbstraction (input :: Term) (hasReference :: Boolean) (output :: Term) | input hasReference -> output
+
+instance etaReduceLambdaFalse :: 
+    ( ShiftTerm term Zero False (Succ Zero) result
+    , DeepEtaReduce result deepResult )
+    => EtaReduceAbstraction term False deepResult
+else instance etaReduceLambdaTrue :: 
+    DeepEtaReduce term result
+    => EtaReduceAbstraction term True (Abstraction (Application result (Var Zero)))
+
+class DeepEtaReduce (input :: Term) (output :: Term) | input -> output
+
+instance deepEtaReduceAbstraction :: 
+    ( HasReference term Zero hasReference
+    , EtaReduceAbstraction term hasReference result) 
+    => DeepEtaReduce (Abstraction (Application term (Var Zero))) result
+else instance deepEtaReduceApplication :: 
+    ( DeepEtaReduce left leftResult
+    , DeepEtaReduce right rightResult) 
+    => DeepEtaReduce (Application left right) (Application leftResult rightResult) 
+else instance deepEtaReduceAbstraction' :: 
+    DeepEtaReduce term result
+    => DeepEtaReduce (Abstraction term) (Abstraction result)
+else instance deepEtaReduceGeneral :: DeepEtaReduce a a
+
+class EtaReduce (input :: Term) (output :: Term) | input -> output
+
+instance etaReduceGeneral :: 
+    ( DeepEtaReduce input reduced
+    , TermsAreEqual input reduced equal
+    , EtaReduceRec reduced equal result )
+    => EtaReduce input result
+
+class EtaReduceRec (reduced :: Term) (equal :: Boolean) (output :: Term) | reduced equal -> output
+
+instance etaReduceTrue :: EtaReduceRec reduced True reduced
+else instance etaReduceFalse :: EtaReduce reduced result => EtaReduceRec reduced False result
+
+-- Conditions
+class TermIf (bool :: Boolean)
+    (onTrue :: Term)
+    (onFalse :: Term)
+    (output :: Term) 
+    | bool onTrue onFalse -> output
+
+instance ifTrue :: TermIf True onTrue onFalse onTrue
+instance ifFalse :: TermIf False onTrue onFalse onFalse
+
+-- Substitution 
+class Substitute (index :: Num) (inside :: Term) (with :: Term) (result :: Term) | index inside with -> result
+
+instance substituteVar :: 
+    ( NAreEqual var index equal
+    , TermIf equal with (Var var) result)
+    => Substitute index (Var var) with result 
+else instance substituteCall :: 
+    ( Substitute index left with leftResult 
+    , Substitute index right with rightResult 
+    ) => Substitute index (Application left right) with (Application leftResult rightResult)
+else instance subsituteAbstraction ::
+    ( ShiftTerm with Zero True (Succ Zero) shifted 
+    , Substitute (Succ index) term shifted result
+    ) => Substitute index (Abstraction term) with (Abstraction result)
+
+-- Beta reduction
+class DeepBetaReduce (term :: Term) (result :: Term) | term -> result
+
+instance deepBetaReduceAbstraction :: DeepBetaReduce term result => DeepBetaReduce (Abstraction term) (Abstraction result)
+else instance deepBetaReudctionApplication ::
+    ( DeepBetaReduce left leftReduced
+    , DeepBetaReduce right rightReduced
+    , ShiftTerm rightReduced Zero True (Succ Zero) rightShifted
+    , Substitute Zero leftReduced rightShifted result
+    , ShiftTerm result Zero False (Succ Zero) result'
+    -- , DeepBetaReduce result' result''
+    ) => DeepBetaReduce (Application (Abstraction left) right) result'
+else instance deepBetaReduceApplication :: 
+    ( DeepBetaReduce left leftResult 
+    , DeepBetaReduce right rightResult 
+    ) => DeepBetaReduce (Application left right) (Application leftResult rightResult)
+else instance deepBetaReduceGeneral :: DeepBetaReduce a a
+
+class BetaReduce (input :: Term) (output :: Term) | input -> output
+
+instance betaReduceGeneral :: 
+    ( DeepBetaReduce input reduced
+    , TermsAreEqual input reduced equal
+    , BetaReduceRec reduced equal result 
+    ) => BetaReduce input result
+
+class BetaReduceRec (reduced :: Term) (equal :: Boolean) (output :: Term) | reduced equal -> output
+
+instance betaReduceTrue :: BetaReduceRec reduced True reduced
+else instance betaReduceFalse :: BetaReduce reduced result => BetaReduceRec reduced False result
+
+-- Church numerals
+class ChurchNumeral (input :: Num) (output :: Term) | input -> output
+
+instance churchNumeralGeneral :: 
+    ChurchNumeralBody x result 
+    => ChurchNumeral x (Abstraction (Abstraction result))
+
+class ChurchNumeralBody (input :: Num) (output :: Term) | input -> output
+
+instance churchNumeralZero :: ChurchNumeralBody Zero (Var Zero)
+else instance churchNumeralSucc ::
+    ChurchNumeralBody x result
+    => ChurchNumeralBody (Succ x) (Application (Var (Succ Zero)) result)
+
+-- Helpers
+data TProxy (a :: Term) = TProxy
+
+var :: forall a. NProxy a -> TProxy (Var a)
+var _ = TProxy
+
+abstract :: forall a. TProxy a -> TProxy (Abstraction a)
+abstract _ = TProxy
+
+application :: forall a b. TProxy a -> TProxy b -> TProxy (Application a b)
+application _ _ = TProxy
+
+infixl 1 application as -$-
+
+hasReference :: forall term index result. 
+    HasReference term index result => 
+    TProxy term -> 
+    NProxy index -> 
+    BProxy result
+hasReference _ _ = BProxy
+
+etaReduce :: forall input output. EtaReduce input output => TProxy input -> TProxy output
+etaReduce _ = TProxy
+
+betaReduce :: forall input output. BetaReduce input output => TProxy input -> TProxy output
+betaReduce _ = TProxy
+
+reduce :: forall input output. Reduce input output => TProxy input -> TProxy output
+reduce _ = TProxy
+
+shiftVar :: forall term over amount result sign. 
+    ShiftTerm term over sign amount result =>
+    TProxy term ->
+    NProxy over ->
+    BProxy sign ->
+    NProxy amount ->
+    TProxy result
+shiftVar _ _ _ _ = TProxy
+
+churchNumeral :: forall int result. ChurchNumeral int result => NProxy int -> TProxy result
+churchNumeral _ = TProxy
+
+areEqual :: forall a b r. TermsAreEqual a b r => TProxy a -> TProxy b -> BProxy r
+areEqual _ _ = BProxy 
+
+-- Tests
+referenceTest :: BProxy True
+referenceTest = hasReference term index
+    where
+    term = abstract (abstract (application (var one) (var two)))
+    index = zero
+
+etaTest :: TProxy (Abstraction (Application (Var Zero) (Var (Succ Zero))))
+etaTest = etaReduce expression
+    where
+    -- Equivalent of (\a b. (\b. b c) a b)
+    expression = abstract (abstract (application (application (abstract (application (var zero) (var three))) (var one)) (var zero)))
+
+
+churchZero :: TProxy (Abstraction (Abstraction (Var Zero)))
+churchZero = churchNumeral zero
+
+churchOne :: TProxy (Abstraction (Abstraction (Application (Var (Succ Zero)) (Var Zero))))
+churchOne = churchNumeral one
+
+churchThree :: TProxy (Abstraction (Abstraction (Application (Var (Succ Zero)) (Application (Var (Succ Zero)) (Application (Var (Succ Zero)) (Var Zero))))))
+churchThree = churchNumeral three
+
+churchAdd :: TProxy (Abstraction (Abstraction (Abstraction (Abstraction (Application (Application (Var (Succ (Succ (Succ Zero)))) (Var (Succ Zero))) (Application (Application (Var (Succ (Succ Zero))) (Var (Succ Zero))) (Var Zero)))))))
+churchAdd = abstract (abstract (abstract (abstract body)))
+    where
+    body :: TProxy _
+    body = (var three) -$- (var one) -$- ((var two) -$- (var one) -$- (var zero))
+
+churchFiveUnReduced :: TProxy (Application (Application (Abstraction (Abstraction (Abstraction (Abstraction (Application (Application (Var (Succ (Succ (Succ Zero)))) (Var (Succ Zero))) (Application (Application (Var (Succ (Succ Zero))) (Var (Succ Zero))) (Var Zero))))))) (Abstraction (Abstraction (Application (Var (Succ Zero)) (Application (Var (Succ Zero)) (Application (Var (Succ Zero)) (Var Zero))))))) (Abstraction (Abstraction (Application (Var (Succ Zero)) (Var Zero)))))
+churchFiveUnReduced = churchAdd -$- churchThree -$- churchOne
+
+termConst :: TProxy (Abstraction (Abstraction (Var (Succ Zero))))
+termConst = abstract (abstract (var one))
+
+termIdentity :: TProxy (Abstraction (Var Zero))
+termIdentity = abstract (var zero)
+
+addTest :: BProxy True
+addTest = areEqual fourRaw fourComputed
+    where
+    fourRaw = churchNumeral four 
+    fourComputed = reduce (churchAdd -$- churchThree -$- churchOne) 
+
+addTest' :: BProxy False
+addTest' = areEqual fiveRaw fourComputed
+    where
+    fiveRaw = churchNumeral five 
+    fourComputed = reduce (churchAdd -$- churchThree -$- churchOne) 
+
+reductionTest :: TProxy (Abstraction (Abstraction (Var Zero)))
+reductionTest = reduce (f -$- arg -$- arg)
+    where
+    f = termConst -$- termIdentity
+    arg = churchZero
+
+-- infinite :: _
+-- infinite = reduce (abstract (t -$- t))
+--     where
+--     t = abstract (var one -$- (var zero -$- var zero))

purescript/typelevel/src/Vec.purs

@@ -0,0 +1,53 @@
+module Vec where
+
+import Num
+
+import Data.Tuple (Tuple)
+import Prim.Ordering (LT)
+import Undefined (undefined)
+
+foreign import data Vec :: Num -> Type -> Type
+
+-- Helpers
+cons :: forall length a. a -> Vec length a -> Vec (Succ length) a
+cons = undefined
+
+nil :: forall a. Vec Zero a 
+nil = undefined
+
+merge :: forall l1 l2 l3 a. Add l1 l2 l3 => Vec l1 a -> Vec l2 a -> Vec l3 a
+merge = undefined
+
+lookup :: forall length index a. Compare index length LT => Vec length a -> NProxy index -> a
+lookup = undefined
+
+take :: forall l i a. Compare i l LT => NProxy i -> Vec l a -> Vec i a
+take = undefined
+
+drop :: forall l l' i a. Sub l i l' => NProxy i -> Vec l a -> Vec l' a
+drop = undefined
+
+product :: forall l l' l'' a b. Multiply l l' l'' => Vec l a -> Vec l' b -> Vec l'' (Tuple a b)
+product = undefined
+
+-- Test
+myVec :: Vec Three String
+myVec = undefined
+
+first :: String
+first = lookup myVec zero 
+
+second :: String
+second = lookup myVec one
+
+third :: String
+third = lookup myVec two
+
+getFourth :: forall a l. Compare Three l LT => Vec l a -> a
+getFourth a = lookup a three 
+
+lastTwo :: Vec Two String
+lastTwo = drop two (cons "something" myVec)
+
+productTest :: Vec (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))))) (Tuple String Int)
+productTest = product (myVec) (cons 1 (cons 4 (cons 7 nil)))