Haskell solution to the Smile problem

-- from here
-- https://www.quora.com/Homework-Question-How-do-I-write-a-program-that-produces-the-following-output-1#

    -- This is a nice problem that we can write a very easy
    -- piece of Haskell code for to demonstrate its simplicity!

    -- First, we need Peano numbers so that we can count things.
    -- Always define your own, never trust the built-in integers!

    data Nat = Zero | Succ Nat
      deriving (Eq, Show)

    -- Now I will set the ground work for the rest of our program.
    -- This is a pretty obvious and self-explanatory data type.
    -- We will use it to create a stream of functors that ends in a Pure constructor.

    data Free f r = Free (f (Free f r)) | Pure r

    -- We need our enriched data type to be a Functor if the base type is a Functor.
    -- If you don't know what a Functor is, just think of a Functor F from category X
    -- to category Y as something that maps every x in X to an F(X) in Y, and every morphism f
    -- to F(f) :: F(A) -> F(B). Importantly, it must preserve idenity and composition of morphisms,
    -- ie forall morphisms f :: A -> B in X we have F(id_A) = id_{F_A} and F ( g . f) = F g . F f
    -- It's very easy when you think about.

    instance Functor f => Functor (Free f) where
      fmap g (Pure a)  = Pure $ g a
      fmap g (Free f) = Free ((g <$>) <$> f)

    -- We will need this because Applicative is a superclass of Monad in the
    -- newest Haskell spec.

    instance Functor f => Applicative (Free f) where
      pure = Pure
      Pure f <*> x = f <$> x
      Free ma <*> b = Free $ (<*> b) <$> ma

    -- From the library definition, "a Monad n is a free Monad for f if every
    -- monad homomorphism from n to another monad m is equivalent to a natural
    -- transformation from f to m."

    instance (Functor f) => Monad (Free f) where
      return = Pure
      (Free x) >>= f = Free (fmap (>>= f) x)
      (Pure r) >>= f = f r

    -- Lifting from a normal functor f to Free f will be handy

    liftF :: (Functor f) => f r -> Free f r
    liftF = Free . fmap Pure

    -- We are done with the pre-requisite definitions.
    -- We can now define a custom DSL to represent our language of smiling.

    data SmileExpr r e = Smile r Nat e | Line e | Done
      deriving (Eq, Show)

    -- We are future proofing our program so it will work with arbitrary
    -- smiling types.

    data SmileType = CapitalSmile deriving (Eq)

    instance Show SmileType where
      show CapitalSmile = "Smile!"

    -- Trivial Functor intsance for our smile language. We of course need
    -- this as our intepreter won't work without a Functor instance.

    instance Functor (SmileExpr r) where
      fmap f (Done) = Done
      fmap f (Line e) = Line $ f e
      fmap f (Smile t n e) = Smile t n (f e)

    -- Lifted helpers to write in our language

    smile t n = liftF $ Smile t n ()
    done = liftF Done
    line = liftF (Line ())

    -- Helper to construct our smiling "tower" per the spec.
    -- What I hope you'll appreciate is that this is still a
    -- pure data representation of our smile language.

    downFrom :: SmileType -> Nat -> Free (SmileExpr SmileType) r
    downFrom t (Succ n) = smile t (Succ n) >> line >> downFrom t n
    downFrom _ Zero = done

    -- Now the interpreter for our DSL. As you can see you can now write arbitrary
    -- interpreters for our language. I encourage you to play with it!

    interpret :: (Show r) => Free (SmileExpr r) k -> IO ()
    interpret (Free Done) = return ()
    interpret (Free (Line e)) = putStrLn "" >> interpret e
    interpret (Free (Smile t (Succ n) e)) = putStr (show t) >> interpret (Free (Smile t n e))
    interpret (Free (Smile _ Zero e)) = interpret e

    -- Now to demonstrate how our interpreter works.

    -- Peano representation of the concept of 'three'.
    -- I leave it as exercise to the reader to generalize this.
    sssz = Succ (Succ (Succ Zero))

    -- We are done! Run the program.
    run :: IO ()
    run = interpret $ downFrom CapitalSmile sssz