shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Make Uncomb work

--- a/Tools/Uncomb.hs

+++ b/Tools/Uncomb.hs

@@ -1,3 +1,4 @@

+{-# OPTIONS_GHC -Wall #-}

 {-# LANGUAGE DeriveDataTypeable #-}

 module Uncomb where

 import Data.Char

@@ -7,8 +8,9 @@

 infix :@

 data Exp

   = S | S' | K | A | U | I | Y | B | B' | Z | C | C' | P | R | O | K2 | K3 | K4 | C'B

-  | Exp :@ Exp | Int Integer | Label Int Exp | Ref Int | Vx

-  deriving (Show, Read, Data)

+  | Add | Sub | Lt

+  | Exp :@ Exp | Int Integer | Label Int Exp | Ref Int | Tick String | Vx

+  deriving (Show, Read, Data, Eq, Ord)

 reduce :: Exp -> Exp

 reduce (((S :@ x) :@ y) :@ z) = (x :@ z) :@ (y :@ z)

@@ -29,31 +31,65 @@

 reduce ((((K3 :@ x) :@ _y) :@ _z) :@ _w) = x

 reduce (((((K4 :@ x) :@ _y) :@ _z) :@ _w) :@ _v) = x

 reduce ((((C'B :@ x) :@ y) :@ z) :@ w) = (x :@ z) :@ (y :@ w)

+reduce (Label _ e) = e

+reduce (Tick _ :@ e) = e

 reduce e = e

-trans :: String -> String

-trace [] = []

-trans (' ':cs) = " :@ " ++ trans cs

-trans ('#':cs) = "Int " ++ trans cs

-trans (':':cs) = "Label " ++ n ++ trans (tail r) where (n,r) = span (/= ' ') cs

-trans ('_':cs) = "Ref " ++ n ++ trans r where (n,r) = span isDigit cs

-trans (c:cs) = c : trans cs

+parseExp :: String -> (Exp, String)

+parseExp (' ':cs) = parseExp cs

+parseExp ('(':cs) = (e1 :@ e2, r'')

+  where (e1, r) = parseExp cs

+        (e2, r') = parseExp r

+        r'' = case r' of (')':s) -> s; _ -> error ")"

+parseExp ('#':cs) = (Int (read n), r) where (n, r) = span isDigit cs

+parseExp (':':cs) = (Label (read n) e, r') where (n, r) = span isDigit cs; (e, r') = parseExp r

+parseExp ('_':cs) = (Ref (read n), r) where (n, r) = span isDigit cs

+parseExp ('!':'"':cs) = (Tick (init n), drop 1 r) where (n, r) = span (/= '"') cs

+parseExp ('+':cs) = (Add, cs)

+parseExp ('-':cs) = (Sub, cs)

+parseExp ('<':cs) = (Lt, cs)

+parseExp ('C':'\'':'B':cs) = (C'B, cs)

+parseExp ('S':'\'':cs) = (S', cs)

+parseExp ('C':'\'':cs) = (C', cs)

+parseExp ('B':'\'':cs) = (B', cs)

+parseExp ('K':'2':cs) = (K2, cs)

+parseExp ('K':'3':cs) = (K3, cs)

+parseExp ('K':'4':cs) = (K4, cs)

+parseExp ('S':cs) = (S, cs)

+parseExp ('K':cs) = (K, cs)

+parseExp ('A':cs) = (A, cs)

+parseExp ('U':cs) = (U, cs)

+parseExp ('I':cs) = (I, cs)

+parseExp ('Y':cs) = (Y, cs)

+parseExp ('B':cs) = (B, cs)

+parseExp ('Z':cs) = (Z, cs)

+parseExp ('C':cs) = (C, cs)

+parseExp ('P':cs) = (P, cs)

+parseExp ('R':cs) = (R, cs)

+parseExp ('O':cs) = (O, cs)

+parseExp ('x':cs) = (Vx, cs)

+parseExp cs = error $ "parseExp: " ++ show (take 20 cs)

+readExp :: String -> Exp

+readExp s =

+  case parseExp s of

+    (e, "") -> e

+    x -> error $ "readExp: " ++ show x

+

 red :: Exp -> Exp

 red = transform reduce

---ttt = (U :@ (K :@ ((B :@ C) :@ (P :@ (Int 111)))))

 s1 = "(U (K ((B C) (P #111))))"

-s1' = trans s1

-t1 = read s1' :: Exp

+t1 = readExp s1

 s2 = "((C ((C (U ((C'B (B' P)) ((B (C' C)) (C P))))) A)) #111)"

-s2' = trans s2

-t2 = read s2' :: Exp

+t2 = readExp s2

-t1x = (t1 :@ Vx)

-t2x = ((t2 :@ Vx))

-

 s3 = "((C B) (C (U (K2 A))))"

-s3' = trans s3

-t3 = read s3' :: Exp

+t3 = readExp s3

+

+s4 = "(:942 ((C ((S ((C <) #2)) (((C' +) (((S' +) ((B :491 ((B !\"F.nfib\") _942)) :4157 ((C -) #1))) ((B _491) ((C -) #2)))) #1))) #1) (_4157 #3))"

+t4 = readExp s4

+

+s5 = "(:942 ((C ((S ((C <) #2)) (((C' +) (((S' +) ((B :491 ((B !\"F.nfib\") _942)) :4157 ((C -) #1))) ((B _491) ((C -) #2)))) #1))) #1) x)"

+t5 = readExp s5

-- 

⑨