CFormImplementation.hs

{-# OPTIONS -fglasgow-exts #-}
-- Do not know precisely which extensions needs adding

-- |An implementation of the AutoForm class for consoles (text-only)
module Graphics.UI.AF.CForm.CFormImplementation
    ( GCForm, GCFormD
    , consoleParentProxy
    , Com(Com), Parent, Com', Identity
    )
where

import Maybe

import qualified Graphics.UI.AF.General as AF
import Graphics.UI.AF.General.MySYB
-- import Graphics.UI.AF.General.CustomTypes
import Graphics.UI.AF.General.InstanceCreator

import Graphics.UI.AF.General.PriLabel

import Control.Monad.Identity

import Monad(zipWithM_)
import IO(hFlush, stdout)

-- |Component parameter for the console instance of AutoForm
data Com a = Com PriLabel (Int -> PriLabel -> IO a)
data Com' a = Com' (Com a)
-- |Satisfiability context parameter for the console instance of AutoForm
type SatCxt = GCFormD
-- |Parent parameter for the console instance of AutoForm
type Parent = Identity

-- |A Parent type proxy
consoleParentProxy :: Parent ()
consoleParentProxy = error "Cannot be instantiated."

instance AF.SimpleDialog Identity where
    errorDialog    = error "Not implemented yet"
    infoDialog     = error "Not implemented yet"
instance AF.SimpleDialog IO where
    errorDialog    = error "Not implemented yet"
    infoDialog     = error "Not implemented yet"

-- class (Action action comH builder)
 --   => AutoForm  (action :: * -> *) (comH :: * -> *) (builder :: * -> *) (satCxt :: * -> *) (com :: * -> * -> *)
-- instance AF.Valued IO Com' Identity  where
instance AF.Action IO Com' where
instance AF.Valued Com   where
instance AF.Valued Com'  where
instance AF.Mergeable Com   where
instance AF.Mergeable Com'  where
instance AF.ValuedAction Com' IO where
instance AF.AutoForm IO Com' Identity SatCxt Com where
    defaultCom x = (gCFormD dict) x -- Com (\indentation -> (gCFormD dict) indentation x)
    label newLabel (Com lbl get)
        = Com (bestLabel (PriLabel UserDefined newLabel) lbl) get
    limit          = error "Not implemented yet"
    builderToCom com = let (Com' (Com lbl f)) = runIdentity com
                       in Com lbl f
    addCom         = return . Com'
    command _ (Com lbl get) execFun
        = do putStrLn "In CForm command"
             get 0 lbl >>= execFun >>= putStr . toString
             return ()

{-
instance AF.AutoForm Com SatCxt Parent where
    display        = error "Not implemented yet"
    hidden         = error "Not implemented yet"
    addTimer       = error "Not implemented yet"
    executeProcess = error "Not implemented yet"
-}

------------------------------------------------------------------------------

type GCFormT a = a -> Com a

-- |The dictionary type for the GCForm class
data GCFormD a = GCFormD { gCFormD    :: GCFormT a
                         , mkComD     :: GCFormT a
                         , gToStringD :: a -> String
                         , gDefaultInstanceD :: a
                         }

-- |Instantiation of the Sat class
instance GCForm a => Sat (GCFormD a)
    where  dict = GCFormD { gCFormD    = gCForm
                          , mkComD     = AF.mkCom
                          , gToStringD = gToString
                          , gDefaultInstanceD = defaultInstance
                          }

-- |The context for generic autoform
gCFormCtx :: Proxy GCFormD
gCFormCtx = error "gCFormCtx"

toString :: Sat (GCFormD a) => a -> String
toString x = (gToStringD dict) x

class (Data GCFormD a, GInstanceCreator a, Show a, Read a, AF.TypePresentation a IO Com' Identity GCFormD Com
      , Eq a) => GCForm a
    where
      gCForm :: GCFormT a
      gCForm x =
          case constrRep (toConstr gCFormCtx x) of
            AlgConstr _         -> gmapCom gCFormCtx (mkComD dict) (gDefaultInstanceD dict) x
            IntConstr _         -> makeComFromSimpleType "Int"
            FloatConstr _       -> makeComFromSimpleType "Float"
            StringConstr _      -> error "No StringConstr constructors"
      defaultInstance :: a
      defaultInstance = fromJust createInstance

makeComFromSimpleType :: (Read a) => String -> Com a
makeComFromSimpleType inputType
    = Com (defaultLabel "") getter
    where
        getter indentation (PriLabel _ label)
            = maybeRead indentation label inputType

requestInput :: Int -> String -> String -> IO String
requestInput indentation label labelType =
    do putStr $ (replicate indentation ' ') ++ label ++ " (" ++ labelType ++ "): "
       hFlush stdout
       getLine

maybeRead :: (Read a) => Int -> String -> String -> IO a
maybeRead indentation label labelType =
    do input <- requestInput indentation label labelType
       case reads input of
         (x, ""):[] -> return x
         _          -> maybeRead indentation label labelType

instance GCForm String
    where
      gCForm _ =
          Com (defaultLabel "")
                  (\indentation  (PriLabel _ label) -> requestInput indentation label "String"
                  )

data GMapHelper a = GMapHelper [PriLabel] (IO a)

gmapCom :: -- forall a (m :: * -> *).
           (Data ctx a) =>
           Proxy ctx -> (forall a1. (Data ctx a1) => GCFormT a1)
                     -> (forall a2. (Data ctx a2) => a2) -> GCFormT a
gmapCom ctx f defaultInstance' y =
    Com (defaultLabel constructorLabel)
             (\indentation (PriLabel _ label) ->
                  do putStrLn (indent indentation ++ "Doing: " ++ label)
                     c <- chooseConstructor indentation
                     let GMapHelper _ getter = gunfold ctx (k indentation) z c
                     getter
             )
    where
      indent indentation = replicate indentation ' '
      chooseConstructor indentation =
          if length constructors' == 1
            then return $ head constructors'
            else do zipWithM_ (\i name -> putStrLn $ indent indentation ++ (show i) ++ ") " ++ name)
                                  ([1..]::[Int]) constructorNames
                    i <- maybeRead indentation "Choose one" "Int"
                    if (i < 1 || i > length constructors')
                      then chooseConstructor indentation
                      else return $ constructors' !! (i - 1)
      k indentation (GMapHelper labels c) =
          GMapHelper (if null labels then [] else tail labels)
           (do let (Com label getFun) = f defaultInstance'
               c' <- c
               x' <- getFun (indentation + 2) (maybe label (\x -> bestLabel label x) (listToMaybe labels))
               return (c' x')
           )
      z c = GMapHelper fieldLabels (return c)
      constructorLabel = showConstr $ toConstr ctx y
      fieldLabels      = map (humanizeLabel . PriLabel FieldName) (constrFields $ toConstr ctx y)
      constructors'    = constructors ctx y
      constructorNames = map showConstr constructors'

instance GCForm Bool
instance GCForm Int
instance GCForm Char
instance GCForm Float
instance GCForm Double