fork download
copy 
  1. data FuncName = Lambda
  2.               | Named String
  3.               deriving (Show, Eq)
  4.  
  5. data OP = OPGT
  6.         | OPLT
  7.         | OPEQ
  8.         deriving (Show,Eq)
  9.  
  10. type VarName = String
  11.  
  12. type EnvEntry = (VarName, MULang)
  13. type MUEnv = [EnvEntry]
  14.  
  15. data MULang = MUVar VarName
  16.             | MUInt Int
  17.             | MUAdd MULang MULang
  18.             | MUFun FuncName String MULang
  19.             | MUIf OP MULang MULang MULang MULang
  20.             | MUCall MULang MULang
  21.             | MUPair MULang MULang
  22.             | MUFst  MULang
  23.             | MUSnd  MULang
  24.             | MULet  VarName MULang MULang
  25.             | MUUnit
  26.             | MUIsUnit MULang
  27.             | MUClosure MUEnv MULang
  28.             deriving (Show,Eq)
  29.  
  30. -- extra "syntax" that can be compiled to a proper MULang in a single pass
  31. data MULangE = MUMLet MUEnv MULang
  32.              | MUIfUnit MULang MULang MULang
  33.              deriving (Show, Eq) 
  34.  
  35. eval :: MUEnv -> MULang -> MULang
  36. eval env x@(MUUnit)         = x
  37. eval env x@(MUInt _)        = x
  38. eval env x@(MUClosure _ _)  = x
  39. eval env   (MUAdd x y)      = MUInt (x' + y')
  40.             where
  41.                 (MUInt x') = (eval env x)
  42.                 (MUInt y') = (eval env y)
  43.  
  44. eval env   (MUVar var)      = x
  45.             where p (Just y) = y 
  46.                   p        _ = MUUnit
  47.                   x = p $ lookup var env
  48.  
  49. eval env   (MUPair e1 e2)   = MUPair (eval env e1) (eval env e2)
  50. eval env   (MUFst expr)     = x
  51.             where (MUPair x _) = eval env expr
  52. eval env   (MUSnd expr)     = x
  53.             where (MUPair _ x) = eval env expr
  54.  
  55. eval env   (MUIsUnit x)     = condt $ eval env x
  56.             where condt (MUUnit) = MUInt 1
  57.                   condt       _  = MUInt 0
  58. eval env   (MULet var el e1) = eval newenv e1
  59.             where newenv = (var, eval env el):env
  60.  
  61. eval env x@(MUFun fname str expr) = (MUClosure env x)
  62.  
  63. eval env   (MUCall e1 e2) = eval newenv fun 
  64.             where
  65.                    closure = eval env e1
  66.                    (MUClosure cenv (MUFun fname param fun)) = closure
  67.                    fparam = eval env e2
  68.                    newenv = function fname ++ [(param, fparam)] ++ cenv
  69.                    function Lambda    = []
  70.                    function (Named x) = [(x, closure)]
  71.  
  72. eval env   (MUIf op x y e1 e2)
  73.                 | x' `opy` y'   = eval env e1
  74.                 | otherwise = eval env e2 
  75.             where
  76.                 (MUInt x') = (eval env x)
  77.                 (MUInt y') = (eval env y)
  78.                 opy = iny op
  79.                 iny (OPGT) = (>)
  80.                 iny (OPLT) = (<)
  81.                 iny (OPEQ) = (==)
  82.  
  83.  
  84. preproc (MUMLet ((v, e):xs) f) = MULet v e (preproc $ MUMLet xs f)
  85. preproc (MUMLet []          f) = f 
  86. preproc (MUIfUnit e e1 e2)     = MUIf (OPEQ) (MUIsUnit e) (MUInt 1) e1 e2 
  87.  
  88. v = preproc $ MUMLet [
  89.             ("double", (MUFun (Lambda) "n"
  90.                             (MUAdd (MUVar "n")
  91.                                    (MUVar "n")
  92.                             )))
  93.            ,("sumlist", (MUFun (Named "sm") "ls"
  94.                             (preproc $ MUIfUnit (MUVar "ls")
  95.                                             (MUInt 0)
  96.                                             (MUAdd
  97.                                                 (MUFst (MUVar "ls"))
  98.                                                 (MUCall (MUVar "sm")
  99.                                                         (MUSnd (MUVar "ls")))))))
  100.            ]
  101.            (MUCall (MUVar "sumlist")
  102.             (toMUPLList [1..4]))
  103.  
  104. toMUPLList :: [Int] -> MULang
  105. toMUPLList = (foldr MUPair MUUnit).(map MUInt)
  106. toHSList :: MULang -> [Int]
  107. toHSList (MUPair (MUInt x) y) = x:(toHSList y)
  108. toHSList (MUUnit)             = []
  109.  
  110. main = putStrLn $ show (eval [] v)
Success #stdin #stdout 0s 6260KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
MUInt 10
https://ideone.com/J26EmS
language:
Haskell (ghc 8.4.4)
created:
10 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!