module Foreign.HacanonLight.Common.THUtils
    ( createArrowType
    , createTupleType
    , createSimpleType
    , createSimpleExpr
    , puts
    , modifyField
    , insertInField
    , internalError
    ) where

import Control.Monad.State
import Language.Haskell.TH
import Data.List (nub,nubBy,sortBy)

createArrowType :: [TypeQ] -> TypeQ
createArrowType = worker
    where worker [x] = x
          worker (x:xs) = appT (appT arrowT x) (worker xs)

createTupleType :: [TypeQ] -> TypeQ
createTupleType [t] = t
createTupleType types = worker (reverse types)
    where worker [] = tupleT len
          worker (x:xs) = appT (worker xs) x
          len = length types

createSimple :: (a -> a -> a) -> a -> [a] -> a
createSimple fn n [] = n
createSimple fn n (x:xs) = createSimple fn n xs `fn` x

createSimpleType :: TypeQ -> [TypeQ] -> TypeQ
createSimpleType = createSimple appT

createSimpleExpr :: ExpQ -> [ExpQ] -> ExpQ
createSimpleExpr = createSimple appE


puts :: [String] -> ExpQ
puts strings
    = [| \value ->
           do state <- get
              put ($(worker fields [| state |] [| value |]))
       |]
    where worker [x] state value
              = recUpdE state [fieldExp x value]
          worker (x:xs) state value
              = recUpdE state [fieldExp x (worker xs (appE (varE x) state) value)]
          fields = map mkName strings



modifyField :: [String] -> ExpQ
modifyField strings
    = [| \fn ->
           do state <- get
              put ($(worker fields [| state |] [| fn |]))
       |]
    where worker [x] state fn
              = recUpdE state [fieldExp x (appE fn (appE (varE x) state))]
          worker (x:xs) state value
              = recUpdE state [fieldExp x (worker xs (appE (varE x) state) value)]
          fields = map mkName strings


insertInField :: [String] -> ExpQ
insertInField strings
    = [| \value ->
           do state <- get
              put ($(worker fields [| state |] [| value |]))
       |]
    where worker [x] state value
              = recUpdE state [fieldExp x (infixE (Just (listE [value])) (varE (mkName "++")) (Just (appE (varE x) state)))]
          worker (x:xs) state value
              = recUpdE state [fieldExp x (worker xs (appE (varE x) state) value)]
          fields = map mkName strings

internalError :: ExpQ
internalError =
    do mod <- currentModule
       [| error $ "Internal error in module: " ++ mod |]