# LANGUAGE DeriveFunctor , FlexibleContexts , TypeSynonymInstances , FlexibleInstances #
module Hattis.Text.Make(makefile, maybeopt, boolopt) where
import Data.Char
import Control.Monad.Free
import Data.List
import Data.Monoid
import Data.Maybe

type Maker a = Free ExprF a

class Sidable a where 
    toRHS :: a -> String
    toLHS :: a -> String

instance Sidable String where
    toRHS = id
    toLHS = map toUpper

instance Sidable Lit where
    toRHS (LitVar str) = "$(" ++ toRHS str ++ ")"
    toRHS (LitStr str) = str

    toLHS (LitVar str) = toLHS str
    toLHS (LitStr str) = toLHS str

class IsLit a where
    toLit :: a -> Lit

instance IsLit Lit where
    toLit = id

instance IsLit String where
    toLit = LitStr


data ExprF a 
    = Var String Lit (Lit -> a)
    | IfEq String String (Maker ()) a
    | IfNeq String String (Maker ()) a
    | Rule String Lit a
    | Comment String a
    | End
    deriving Functor

data Lit  
    = LitVar String
    | LitStr String


(.+.) :: (Sidable a, Sidable b) => a -> b -> Lit
a .+. b = LitStr (toRHS a ++ " " ++ toRHS b)

comment = liftF . flip Comment ()

var :: (Sidable a, IsLit b) => a -> b -> Maker Lit
var str lit = liftF $ Var (toLHS str) (toLit lit) id

infixr 5 .=.
a .=. b = var a b

infixr 5 .+=.
a .+=. b = a .=. a .+. b

ifeq :: (Sidable a, Sidable b) => a -> b -> Maker c -> Maker ()
ifeq l1 l2 clause = liftF $ IfEq (toRHS l1) (toRHS l2) (clause *> make) () 
a =?= b = ifeq a b 

ifneq :: (Sidable a, Sidable b) => a -> b -> Maker c -> Maker ()
ifneq l1 l2 clause = liftF $ IfNeq (toRHS l1) (toRHS l2) (clause *> make) () 
a =\= b = ifneq a b 


rule :: String -> Lit -> Maker ()
rule str lit = liftF $ Rule str lit ()

make :: Maker a
make = liftF End

maybeopt str mb opts cont = do
    var <- filter isAlpha str .=. fromMaybe "" mb
    cont
    var =\= "" $ 
        opts .+=. str .+. var

boolopt str bool opts cont = do
    var <- filter isAlpha str .=. if bool then "yes" else "no"
    cont 
    var =?= "yes" $
        opts .+=. str

makefile hver id files opts = showMake $ do
    comment $ "Makefile generated by Hattis " ++ hver 
    id     <- "id"     .=. "\"" ++ id ++ "\""
    files  <- "files"  .=. intercalate " " files
    var    <- "opts"   .=. ""
    foldr ($ var) (return ()) opts 
    rule "default" $ "hattis" .+. id .+. files .+. var
    make

showMake (Free (Var str lit n)) = 
    map toUpper str 
        ++ " := " 
        ++ toRHS lit ++ "\n"
        ++ (showMake . n $ LitVar str)

showMake (Free (IfNeq l1 l2 inner n)) = 
    "\nifneq ("  ++ l1 ++ "," ++ l2 ++ ")\n"
        ++ (unlines . map ('\t':) . lines $ showMake inner)
        ++ "endif\n"
        ++ showMake n

showMake (Free (IfEq l1 l2 inner n)) = 
    "\nifeq ("  ++ l1 ++ "," ++ l2 ++ ")\n"
        ++ (unlines . map ('\t':) . lines $ showMake inner)
        ++ "endif\n"
        ++ showMake n

showMake (Free (Rule str lit n)) = 
    "\n.PHONY: " ++ str
          ++ "\n" ++ str
          ++ ":\n\t" 
          ++ toRHS lit
          ++ showMake n ++ "\n"

showMake (Free (Comment str n)) = "# " ++ str ++ "\n" ++ showMake n
showMake (Free End) = ""

# LANGUAGE DeriveFunctor , FlexibleContexts , TypeSynonymInstances , FlexibleInstances #
module Hattis.Text.Make(makefile, maybeopt, boolopt) where
import Data.Char
import Control.Monad.Free
import Data.List
import Data.Monoid
import Data.Maybe

type Maker a = Free ExprF a

class Sidable a where 
    toRHS :: a -> String
    toLHS :: a -> String

instance Sidable String where
    toRHS = id
    toLHS = map toUpper

instance Sidable Lit where
    toRHS (LitVar str) = "$(" ++ toRHS str ++ ")"
    toRHS (LitStr str) = str

    toLHS (LitVar str) = toLHS str
    toLHS (LitStr str) = toLHS str

class IsLit a where
    toLit :: a -> Lit

instance IsLit Lit where
    toLit = id

instance IsLit String where
    toLit = LitStr


data ExprF a 
    = Var String Lit (Lit -> a)
    | IfEq String String (Maker ()) a
    | IfNeq String String (Maker ()) a
    | Rule String Lit a
    | Comment String a
    | End
    deriving Functor

data Lit  
    = LitVar String
    | LitStr String


(.+.) :: (Sidable a, Sidable b) => a -> b -> Lit
a .+. b = LitStr (toRHS a ++ " " ++ toRHS b)

comment = liftF . flip Comment ()

var :: (Sidable a, IsLit b) => a -> b -> Maker Lit
var str lit = liftF $ Var (toLHS str) (toLit lit) id

infixr 5 .=.
a .=. b = var a b

infixr 5 .+=.
a .+=. b = a .=. a .+. b

ifeq :: (Sidable a, Sidable b) => a -> b -> Maker c -> Maker ()
ifeq l1 l2 clause = liftF $ IfEq (toRHS l1) (toRHS l2) (clause *> make) () 
a =?= b = ifeq a b 

ifneq :: (Sidable a, Sidable b) => a -> b -> Maker c -> Maker ()
ifneq l1 l2 clause = liftF $ IfNeq (toRHS l1) (toRHS l2) (clause *> make) () 
a =\= b = ifneq a b 


rule :: String -> Lit -> Maker ()
rule str lit = liftF $ Rule str lit ()

make :: Maker a
make = liftF End

maybeopt str mb opts cont = do
    var <- filter isAlpha str .=. fromMaybe "" mb
    cont
    var =\= "" $ 
        opts .+=. str .+. var

boolopt str bool opts cont = do
    var <- filter isAlpha str .=. if bool then "yes" else "no"
    cont 
    var =?= "yes" $
        opts .+=. str

makefile hver id files opts = showMake $ do
    comment $ "Makefile generated by Hattis " ++ hver 
    id     <- "id"     .=. "\"" ++ id ++ "\""
    files  <- "files"  .=. intercalate " " files
    var    <- "opts"   .=. ""
    foldr ($ var) (return ()) opts 
    rule "default" $ "hattis" .+. id .+. files .+. var
    make

showMake (Free (Var str lit n)) = 
    map toUpper str 
        ++ " := " 
        ++ toRHS lit ++ "\n"
        ++ (showMake . n $ LitVar str)

showMake (Free (IfNeq l1 l2 inner n)) = 
    "\nifneq ("  ++ l1 ++ "," ++ l2 ++ ")\n"
        ++ (unlines . map ('\t':) . lines $ showMake inner)
        ++ "endif\n"
        ++ showMake n

showMake (Free (IfEq l1 l2 inner n)) = 
    "\nifeq ("  ++ l1 ++ "," ++ l2 ++ ")\n"
        ++ (unlines . map ('\t':) . lines $ showMake inner)
        ++ "endif\n"
        ++ showMake n

showMake (Free (Rule str lit n)) = 
    "\n.PHONY: " ++ str
          ++ "\n" ++ str
          ++ ":\n\t" 
          ++ toRHS lit
          ++ showMake n ++ "\n"

showMake (Free (Comment str n)) = "# " ++ str ++ "\n" ++ showMake n
showMake (Free End) = ""
