dsl/dsl.icl

   1 module dsl
   2
   3 import StdEnv
   4
   5 import Data.Func => qualified app
   6 import Data.Functor
   7 import Data.Either
   8 import Data.GenEq
   9 import Data.Functor.Identity
  10 import Control.Applicative
  11 import Control.Monad => qualified join
  12 import Text
  13
  14 import Text.Parsers.Simple.Core
  15
  16 class Symantics v where
  17         int  :: Int -> v Int
  18         bool :: Bool -> v Bool
  19         lam  :: ((v a) -> v b) -> v (a -> b)
  20         app  :: (v (a -> b)) (v a) -> v b
  21         Fix  :: ((v a) -> (v a)) -> v a
  22         add  :: (v a) (v a) -> v a | + a
  23         mul  :: (v a) (v a) -> v a | * a
  24         leq  :: (v a) (v a) -> v Bool | Ord a
  25         If   :: (v Bool) (v a) (v a) -> v a
  26
  27 //Run the object
  28 :: Run a = Run a
  29 runRun (Run a) = a
  30 instance Functor Run where fmap f a = Run $ f $ runRun a
  31 instance pure Run where pure a = Run a
  32 instance <*> Run where <*> a b = Run $ runRun a $ runRun b
  33 instance Symantics Run where
  34         int a    = pure a
  35         bool a   = pure a
  36         lam f    = pure $ runRun o f o Run
  37         app f a  = f <*> a
  38         Fix f    = pure $ let x = runRun $ f $ pure x in x
  39         add a b  = (+) <$> a <*> b
  40         mul a b  = (*) <$> a <*> b
  41         leq a b  = (<=) <$> a <*> b
  42         If i t e = if` <$> i <*> t <*> e
  43
  44 //Length of the object
  45 :: Length a = Length Int
  46 runLength (Length i) = i
  47 (+.) infixl 6
  48 (+.) (Length a) (Length b) = Length $ a + b
  49 instance one (Length a) where one = Length 1
  50 instance zero (Length a) where zero = Length 0
  51 instance Symantics Length where
  52         int _    = one
  53         bool _   = one
  54         lam f    = f zero +. one
  55         app f a  = f +. a +. one
  56         Fix f    = f zero +. one
  57         add a b  = a +. b +. one
  58         mul a b  = a +. b +. one
  59         leq a b  = a +. b +. one
  60         If i t e = i +. t +. e +. one
  61
  62 //Print the object
  63 :: Print a = Print (Int [String] -> [String])
  64 runPrint (Print a) = a
  65 print a = concat $ runPrint a 0 []
  66 var i = "v" +++ toString i
  67 show a = Print \_ c->[toString a:c]
  68 binop op (Print a) (Print b) = Print \i c->["(":a i [op: b i [")":c]]]
  69 instance Symantics Print where
  70         int a    = show a
  71         bool a   = show a
  72         lam f    = Print \i c->["(\\", var i, ".":runPrint (f $ show $ var i) (i+1) [")":c]]
  73         app f a  = Print \i c->["(":runPrint f i [" ":runPrint a i [")":c]]]
  74         Fix f    = Print \i c->["fix (\\","self.":runPrint (f $ show "self") (i+1) [")":c]]
  75         add a b  = binop "+" a b
  76         mul a b  = binop "*" a b
  77         leq a b  = binop "<=" a b
  78         If p t e = Print \i c->["if ":runPrint p i [" then ":runPrint t i [" else ":runPrint e i c]]]
  79
  80 //Parsing
  81 :: Token = IntToken Int | BoolToken Bool | BrackOpenToken | BrackCloseToken | LeqToken | AddToken | MulToken | IfToken
  82 derive gEq Token
  83 instance == Token where == a b = a === b
  84
  85 lex :: [Char] -> Either [String] [Token]
  86 lex [] = Right []
  87 lex [')':cs] = clex cs BrackCloseToken
  88 lex ['(':cs] = clex cs BrackOpenToken
  89 lex ['<=':cs] = clex cs LeqToken
  90 lex ['+':cs] = clex cs AddToken
  91 lex ['*':cs] = clex cs MulToken
  92 lex ['True':cs] = clex cs $ BoolToken True
  93 lex ['False':cs] = clex cs $ BoolToken False
  94 lex ['-',c:cs]
  95         | isDigit c = lex [c:cs] >>= \v->case v of
  96                 [IntToken i:rest] = Right [IntToken (~i):rest]
  97                 x = pure x
  98 lex [c:cs]
  99         | isSpace c = lex cs
 100         | isDigit c
 101                 # (d, cs) = span isDigit [c:cs]
 102                 = clex cs $ IntToken $ toInt $ toString d
 103         = Left ["Unexpected: " +++ toString c +++ " ord: " +++ toString (toInt c)]
 104
 105 clex :: [Char] Token -> Either [String] [Token]
 106 clex cs t = (\ts->[t:ts]) <$> lex cs
 107
 108 class parseSym a where
 109         parseSym :: Parser Token (v a) | Symantics v
 110 instance parseSym Int where
 111         parseSym
 112                 =   flip pChainl1 (add <$ pToken AddToken)
 113                 $   flip pChainl1 (mul <$ pToken MulToken)
 114                 $   pToken BrackOpenToken *> parseSym <* pToken BrackCloseToken
 115                 <|> If <$ pToken IfToken <*> parseSym <*> parseSym <*> parseSym
 116                 <|> int <$> pInt
 117         where
 118                 pInt = pSatisfy (\t->t=:(IntToken _)) >>= \(IntToken i)->pure i
 119 instance parseSym Bool where
 120         parseSym
 121                 =   leq <$> parseSymInt <* pToken LeqToken <*> parseSymInt
 122                 <|> If <$ pToken IfToken <*> parseSym <*> parseSym <*> parseSym
 123                 <|> pToken BrackOpenToken *> parseSym <* pToken BrackCloseToken
 124                 <|> bool <$> pBool
 125         where
 126                 pBool = pSatisfy (\t->t=:(BoolToken _)) >>= \(BoolToken b)->pure b
 127
 128                 parseSymInt :: Parser Token (v Int) | Symantics v
 129                 parseSymInt = parseSym
 130
 131 Start = print <$> exp
 132 where
 133         exp :: Either [String] (v Bool) | Symantics v
 134         exp = lex (fromString inp) >>= parse parseSym
 135
 136         inp = "1+2*3 <= 42*42"
 137 //Start =
 138 //      [ toString $ runRun fourtytwo
 139 //      , print fourtytwo
 140 //      , toString $ runRun true
 141 //      , print true
 142 //      , toString $ runRun powfix33
 143 //      , print powfix33
 144 //      , toString $ runRun factfix5
 145 //      , print factfix5
 146 //      ]
 147
 148 fourtytwo :: v Int | Symantics v
 149 fourtytwo = add (int 38) (int 4)
 150
 151 true :: v Bool | Symantics v
 152 true = app (lam (\x->x)) (bool True)
 153
 154 powfix = lam \x->Fix \self->lam \n->
 155         If (leq n (int 0)) (int 1)
 156                 (mul x (app self (add n (int -1))))
 157
 158 powfix33 = app (app powfix (int 3)) (int 3)
 159
 160 factfix = Fix \self->lam \n->
 161         If (leq n (int 0)) (int 1)
 162                 (mul n (app self (add n (int -1))))
 163
 164 factfix5 = app factfix (int 5)