Created
December 30, 2017 00:48
-
-
Save giuliohome/b93685d3f18c1ac885943c3d984d5c8d to your computer and use it in GitHub Desktop.
A complete example of DSL in Haskell
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DeriveFunctor #-} | |
-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
-- {-# LANGUAGE XRankNTypes #-} | |
-- run this online https://repl.it/repls/GraciousCooperativeNijssenissdwarfchihlid | |
import Control.Applicative -- <$> | |
import Control.Monad | |
data Free f r = Free (f (Free f r)) | Pure r | |
data Op next | |
= Push Double next -- ^ Push element to the stack | |
| Pop (Maybe Double -> next) -- ^ Pop element and return it, if it exists | |
| Flip next -- ^ Flip top two element of stack, if they exist | |
| Add next -- ^ Add top two elements, if they exist | |
| Subtract next | |
| Multiply next | |
| Divide next | |
| End -- ^ Terminate program | |
deriving (Functor) | |
-- instance Functor f => Monad (Free f) where | |
-- return x = Pure x | |
-- (Pure r) >>= f = f r | |
-- (Free x) >>= f = Free (fmap (>>= f) x) | |
instance Functor f => Functor (Free f) where | |
fmap g (Pure a) = Pure (g a) | |
fmap g (Free fv) = Free ((g <$>) <$> fv) | |
instance Functor f => Monad (Free f) where | |
return = Pure | |
Pure a >>= k = k a | |
Free fv >>= k = Free ((k =<<) <$> fv) | |
instance Functor f => Applicative (Free f) where | |
pure = return | |
fg <*> fv = ap fg fv | |
liftF :: (Functor f) => f r -> Free f r | |
liftF command = Free (fmap Pure command) | |
--type Adder a = Free AdderF a | |
type Program a = Free Op a | |
push :: Double -> Program () | |
push x | |
= liftF $ Push x () | |
add :: Program () | |
add = liftF $ Add () | |
multiply :: Program () | |
multiply = liftF $ Multiply () | |
done = liftF End | |
end | |
= liftF End | |
--prog0 :: forall a. Program a | |
prog0 = do | |
push 3 | |
push 2 | |
add | |
end | |
--Push 3 $ | |
--Push 2 $ | |
--Add $ | |
--End | |
--prog :: forall a. Program a | |
prog2 = do | |
push 2 | |
push 2 | |
multiply | |
push 3 | |
push 3 | |
multiply | |
add | |
end | |
modStack :: (a -> a -> a) -> [a] -> [a] | |
modStack f (x : x' : xs) | |
= f x x' : xs | |
modStack _ xs | |
= xs | |
newtype State s a = State { runState :: s -> (a,s) } | |
instance Monad (State s) where | |
return x = State $ \s -> (x,s) | |
(State h) >>= f = State $ \s -> let (a, newState) = h s | |
(State g) = f a | |
in g newState | |
instance Functor (State s) where | |
fmap = Control.Monad.liftM | |
instance Applicative (State s) where | |
pure = return | |
(<*>) = Control.Monad.ap | |
evalState :: State s a -> s -> a | |
evalState p s = fst (runState p s) | |
execState :: State s a -> s -> s | |
execState p s = snd (runState p s) | |
modify :: (s -> s) -> State s () | |
modify f = | |
State (\s -> ( (), f s )) | |
interpret prog | |
= execState (interpret' prog) [] | |
where | |
interpret' :: Program a -> State [Double] () | |
interpret' (Free (Push x next)) = do | |
modify (x :) | |
interpret' next | |
interpret' (Free (Add next)) = do | |
modify $ modStack (+) | |
interpret' next | |
interpret' (Free (Subtract next)) = do | |
modify $ modStack (-) | |
interpret' next | |
interpret' (Free (Multiply next)) = do | |
modify $ modStack (*) | |
interpret' next | |
interpret' (Free (Divide next)) = do | |
modify $ modStack (/) | |
interpret' next | |
interpret' (Free End) | |
= return () | |
main = do | |
print $ interpret prog0 | |
print $ interpret prog2 | |
print "check it out" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment