Started transpiler

4 files changed, 51 insertions, 12 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
index 27a8bdc..e907d96 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -22,21 +22,11 @@ import           Data.IORef                     ( IORef
                                                 )
 import           Data.Map                       ( Map )
 import qualified Data.Map                      as Map
-
-data Term = Abs Term | App Term Term | Idx Int
-  deriving (Eq, Ord)
+import           Term
+import           Utils
 
 type Birb = Char
 
-invalid :: a
-invalid = error "invalid program state"
-
-instance Show Term where
-  showsPrec _ (Abs body) = showString "[" . shows body . showString "]"
-  showsPrec _ (App lhs rhs) =
-    showString "(" . shows lhs . showString " " . shows rhs . showString ")"
-  showsPrec _ (Idx i) = shows i
-
 birbify :: Term -> Map Term Birb -> String
 birbify t m | t `Map.member` m = [Map.findWithDefault invalid t m]
             | (Abs a) <- t     = "[" ++ birbify a m ++ "]"
diff --git a/src/Term.hs b/src/Term.hs
new file mode 100644
index 0000000..081363d
--- /dev/null
+++ b/src/Term.hs
@@ -0,0 +1,34 @@
+module Term
+  ( Term(..)
+  , fromBLC
+  ) where
+
+import           Utils
+
+data Term = Abs Term | App Term Term | Idx Int
+  deriving (Eq, Ord)
+
+instance Show Term where
+  showsPrec _ (Abs body) = showString "[" . shows body . showString "]"
+  showsPrec _ (App lhs rhs) =
+    showString "(" . shows lhs . showString " " . shows rhs . showString ")"
+  showsPrec _ (Idx i) = shows i
+
+fromBLC' :: String -> (Term, String)
+fromBLC' inp = case inp of
+  '0' : '0' : rst -> let (e, es) = fromBLC' rst in (Abs e, es)
+  '0' : '1' : rst ->
+    let (exp1, rst1) = fromBLC' rst
+        (exp2, rst2) = fromBLC' rst1
+    in  (App exp1 exp2, rst2)
+  '1' : _ : rst -> binaryBruijn rst
+  _             -> invalid
+ where
+  binaryBruijn rst =
+    let idx = length (takeWhile (== '1') inp) - 1
+    in  case rst of
+          "" -> (Idx idx, "")
+          _  -> (Idx idx, drop idx rst)
+
+fromBLC :: String -> Term
+fromBLC = fst . fromBLC'
diff --git a/src/Transpile.hs b/src/Transpile.hs
new file mode 100644
index 0000000..2b8134f
--- /dev/null
+++ b/src/Transpile.hs
@@ -0,0 +1,8 @@
+module Transpile
+  ( transpileSKI
+  ) where
+
+import           Term
+
+transpileSKI :: Term -> SKI
+transpileSKI t = t
diff --git a/src/Utils.hs b/src/Utils.hs
new file mode 100644
index 0000000..ec5f9a7
--- /dev/null
+++ b/src/Utils.hs
@@ -0,0 +1,7 @@
+module Utils
+  ( invalid
+  ) where
+
+invalid :: a
+invalid = error "invalid program state"
+