{-# LANGUAGE DeriveDataTypeable #-}

module Data.Derive.DSL.DSL where

import Data.Derive.DSL.HSE
import Data.List
import Data.Data
import Data.Generics.Uniplate.DataOnly

data DSL = App String DSL{-List-}
         | Concat DSL
         | Reverse DSL
         | String String
         | ShowInt DSL
         | Int Integer
         | List [DSL]
         
         | MapField DSL
         | MapCtor DSL
         | DataName
         | CtorName
         | CtorIndex
         | CtorArity
         | FieldIndex
         
         | Fold DSL DSL
         | Head
         | Tail
         
         | Instance [String] String DSL{-[InstDecl]-}
         | Application DSL{-List-}
           deriving (Data,Typeable,Show)

box x = List [x]
nil = List []
append x y = Concat $ List [x,y]


fromOut :: Output -> DSL
fromOut (OApp x y) = App x (List $ map fromOut y)
fromOut (OList x) = List (map fromOut x)
fromOut (OString x) = String x
fromOut x = error $ show ("fromOut",x)


{-
_1 s x1 = App s $ List [x1]
_2 s x1 x2 = App s $ List [x1,x2]
_3 s x1 x2 x3 = App s $ List [x1,x2,x3]
_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]

o x = fromOut $ out x

dslEq :: DSL
dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull
    where
        match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])
        vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))
        bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]
        pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")
        var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)

        dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]
-}


simplifyDSL :: DSL -> DSL
simplifyDSL = transform f
    where
        f (Concat (List xs)) = case g xs of
            [x] -> x
            [] -> List []
            xs -> Concat $ List xs
        f x = x

        g (List x:List y:zs) = g $ List (x++y):zs
        g (List []:xs) = g xs
        g (String "":xs) = g xs
        g (x:xs) = x : g xs
        g [] = []


prettyTex :: DSL -> String
prettyTex = f id . transform g
    where
        bracket x = "(" ++ x ++ ")"
    
        f b (App x (List [])) = x
        f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs
        f b (App x y) = b $ x ++ " " ++ f bracket y
        f b (Concat x) = b $ "concat " ++ f bracket x
        f b (Reverse x) = b $ "reverse " ++ f bracket x
        f b (String x) = show x
        f b (ShowInt x) = b $ "showInt " ++ f bracket x
        f b (Int x) = show x
        f b (List []) = "nil"
        f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"
        f b (MapField x) = b $ "mapField " ++ f bracket x
        f b (MapCtor x) = b $ "mapCtor " ++ f bracket x
        f b DataName = "dataName"
        f b CtorName = "ctorName"
        f b CtorIndex = "ctorIndex"
        f b CtorArity = "ctorArity"
        f b FieldIndex = "fieldIndex"
        f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y
        f b Head = "head"
        f b Tail = "tail"
        f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z
        f b (Application x) = b $ "application " ++ f bracket x

        g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y
        g x = x