swizard task through Makefile generation

Main.hs

{-# LANGUAGE TypeFamilies, DeriveFunctor, OverloadedStrings, DeriveFoldable, FlexibleContexts #-}
module Main (main) where
import Prelude hiding (Foldable)
import qualified Prelude as P (Foldable)
import Data.Functor.Foldable
import Data.Foldable (toList)
import Language.Sexp
import Data.Maybe

data Op = Plus | Star | Minus deriving Show

data SexprB a = Ap Op a a | N Integer deriving (Functor, Show, P.Foldable)

fromRight x = case x of Right a -> a

foo = fromRight $ parseSexp "foo" "(+ 1 2)"
bar = fromRight $ parseSexp "foo" "(+ (+ 1 2) (+ 3 4))"
baz = fromRight $ parseSexp "foo" "(+ (+ 1 2) (+ 3 (+ 4 5)))"
baz' = fromRight $ parseSexp "foo" "(+ (+ (+ 0 1) 2) (+ 3 (+ 4 5)))"
quux = fromRight $ parseSexp "foo" "(+ 3 (+ 4 5))"

type instance Base Sexp = SexprB

instance Foldable Sexp where
        project (Atom _ (AtomInt a)) = N a
        project (List _ [Atom _ (AtomSymbol op), a, b]) = Ap (projectOp op)a b

projectOp "+" = Plus
projectOp "-" = Minus
projectOp "*" = Star

embedOp Plus = (+)
embedOp Minus = (-)
embedOp Star = (*)

eval x = cata phi x where
        phi (Ap op a b) = embedOp op a b
        phi (N x) = x

type Cata x = SexprB x -> x

data FlatDep a = FlatDep a [a] deriving (Show, Functor)

labelChildren t x = concat $ zipWith (maybe [] . t) "lr" $ toList x

compileFlat x = fromJust $ cata phi x where
        phi :: Cata (Maybe [FlatDep String])
        phi (N _) = Nothing
        phi x @ (Ap op a b) = Just $
                        FlatDep "" (labelChildren withConst x) : (labelChildren withPrefix x) where
                withConst c = const [c : ""]
                withPrefix c = map $ ((c :) <$>)

pretty :: [FlatDep String] -> String
pretty (FlatDep "" dd : t) = concatMap p $ FlatDep "all" dd : t where
        p (FlatDep l dd) = l ++ ":" ++ concatMap (\d -> " " ++ d) dd  ++ "\n\tsleep 2\n"
main = putStrLn $ pretty $ compileFlat baz'