-------------------------------------------------------------------------------
-- |
-- Module      :  GenEitherTypes
-- Copyright   :  (c) University of Kansas
-- License     :  BSD3
-- Stability   :  experimental
--
-- Generator for Haskino Ether types
-------------------------------------------------------------------------------

module Main where

typeNameList       = ["Unit", "Bool", "W8", "W16", "W32",
                      "I8", "I16", "I32", "I", "L8", "Float"]
typeList           = ["()", "Bool", "Word8", "Word16", "Word32",
                      "Int8", "Int16", "Int32", "Int", "[Word8]", "Float"]
bindList           = ["Unit", "B", "W8", "W16", "W32",
                      "I8", "I16", "I32", "I", "List8", "Float"]
compTypeList       = ["Unit", "Bool", "Word8", "Word16", "Word32",
                      "Int8", "Int16", "Int32", "Int", "List8", "Float"]
packTypeList       = ["UNIT", "BOOL", "WORD8", "WORD16", "WORD32",
                      "INT8", "INT16", "INT32", "INT", "LIST8", "FLOAT"]
typeNameTypeList   = zip typeNameList typeList
typeNameTypeCombos = [ (x,y) | x<-typeNameTypeList, y<-typeNameTypeList ]
typeNameCombos = [ (x,y)  | x<-typeNameList, y<-typeNameList]
typeNameBindList   = zip typeNameList bindList
typeNameBindCombos = [ (x,y) | x<-typeNameBindList, y<-typeNameBindList ]
typeNameCompTypeList   = zip typeNameList compTypeList
typeNameCompTypeCombos = [ (x,y) | x<-typeNameCompTypeList, y<-typeNameCompTypeList ]
typeNameBindCompTypeList   = zip3 typeNameList bindList compTypeList
typeNameBindCompTypeCombos = [ (x,y) | x<-typeNameBindCompTypeList, y<-typeNameBindCompTypeList ]
typeNameBindPackTypeList   = zip3 typeNameList bindList packTypeList
typeNameBindPackTypeCombos = [ (x,y) | x<-typeNameBindPackTypeList, y<-typeNameBindPackTypeList ]
typeNamePackTypeList = zip typeNameList packTypeList
typeNamePackTypeCombos = [ (x,y) | x<-typeNamePackTypeList, y<-typeNamePackTypeList ]

genEitherPrim :: ((String, String) , (String, String)) -> String
genEitherPrim ((tyn1,ty1), (tyn2, ty2)) =
    "     IfThenElse" ++ tyn1 ++ tyn2 ++ spaces ++ ":: Expr Bool" ++ argStrs ++ returnStr ++ "\n"
  where
    strLens = (length tyn1) + (length tyn2)
    spaces = replicate (11 - strLens) ' '
    argStr = " -> Arduino (ExprEither " ++ ty1 ++ " " ++ ty2 ++ ")"
    argStrs = concat $ replicate 2 argStr
    returnStr = " -> ArduinoPrimitive (ExprEither " ++ ty1 ++ " " ++ ty2 ++ ")"

genIteratePrim :: ((String, String) , (String, String)) -> String
genIteratePrim ((tyn1,ty1), (tyn2, ty2)) =
    "     Iterate" ++ tyn1 ++ tyn2 ++ "E" ++ spaces ++ ":: Expr " ++ ty1 ++
    " -> (Expr " ++ ty1 ++ " -> Arduino (ExprEither " ++ ty1 ++ " " ++
    ty2 ++ ")) -> ArduinoPrimitive (Expr " ++ ty2 ++ ")" ++ "\n"
  where
    strLens = (length tyn1) + (length tyn2)
    spaces = replicate (13 - strLens) ' '

genIterateInst :: ((String, String) , (String, String)) -> String
genIterateInst ((tyn1,ty1), (tyn2, ty2)) =
    "instance ArduinoIterate " ++ ty1 ++ " " ++ ty2 ++ " where\n" ++
    "    iterateE iv bf = Arduino $ primitive $ Iterate" ++ tyn1 ++ tyn2 ++ "E iv bf\n" ++
    "    ifThenElseEither be te ee = Arduino $ primitive $ IfThenElse"++ tyn1 ++ tyn2 ++ " be te ee\n\n"

genShowIf :: ((String, String) , (String, String)) -> String
genShowIf ((tyn1, _), (tyn2, _)) =
    "      showProcedure (IfThenElse" ++ tyn1 ++ tyn2 ++ " e cb1 cb2) =\n" ++
    "          showIfThenElseEitherProcedure e cb1 cb2\n"

genShowIter :: ((String, String) , (String, String)) -> String
genShowIter ((tyn1,ty1), (tyn2, ty2)) =
    "      showProcedure (Iterate" ++ tyn1 ++ tyn2 ++ "E iv bf) = do\n" ++
    "          i <- nextBind\n" ++
    "          let bi = RemBind" ++ ty1 ++ " i\n" ++
    "          j <- nextBind\n" ++
    "          let bj = RemBind" ++ ty2 ++ " j\n" ++
    "          _ <- showIterateProcedure i bi j bj iv bf\n" ++
    "          return bj\n"

genCompIf :: ((String, String) , (String, String)) -> String
genCompIf ((tyn1, ty1), (tyn2, ty2)) =
    "compileProcedure (IfThenElse" ++ tyn1 ++ tyn2 ++ " e cb1 cb2) =\n" ++
    "    compileIfThenElseEitherProcedure " ++ ty1 ++ "Type " ++ ty2 ++ "Type e cb1 cb2\n"

genCompIter :: ((String, String, String) , (String, String, String)) -> String
genCompIter ((tyn1, ty1, cty1), (tyn2, ty2, cty2)) =
    "compileProcedure (Iterate" ++ tyn1 ++ tyn2 ++ "E iv bf) = do\n" ++
    "    i <- nextBind\n" ++
    "    let bi = RemBind" ++ ty1 ++ " i\n" ++
    "    j <- nextBind\n" ++
    "    let bj = RemBind" ++ ty2 ++ " j\n" ++
    "    _ <- compileIterateProcedure " ++ cty1 ++ "Type " ++ cty2 ++ "Type i bi j bj iv bf\n" ++
    "    return bj\n"

genPackIf :: ((String, String) , (String, String)) -> String
genPackIf ((tyn1,ty1), (tyn2,_)) =
    "      packProcedure (IfThenElse" ++ tyn1 ++ tyn2 ++ " e cb1 cb2) = do\n" ++
    "          i <- packIfEitherProcedure (IfThenElse" ++ tyn1 ++ tyn2 ++ " e cb1 cb2)\n" ++
    "          return $ ExprLeft $ RemBind" ++ ty1 ++ " i\n"

genPackIter :: ((String, String) , (String, String)) -> String
genPackIter ((tyn1,_), (tyn2, ty2)) =
    "      packProcedure (Iterate" ++ tyn1 ++ tyn2 ++ "E iv bf) = do\n" ++
    "          i <- packIterateProcedure (Iterate" ++ tyn1 ++ tyn2 ++ "E iv bf)\n" ++
    "          return $ RemBind" ++ ty2 ++ " i\n"

genPackageIf :: ((String, String) , (String, String)) -> String
genPackageIf ((tyn1,ty1), (tyn2,ty2)) =
    "    packageProcedure' (IfThenElse" ++ tyn1 ++ tyn2 ++ " e cb1 cb2) ib' = packageIfThenElseEitherProcedure EXPR_" ++ ty1 ++ " EXPR_" ++ ty2 ++ " ib' e cb1 cb2\n"

genPackageIter :: ((String, String, String) , (String, String, String)) -> String
genPackageIter ((tyn1, ty1, cty1), (tyn2, _, cty2)) =
    "    packageProcedure' (Iterate" ++ tyn1 ++ tyn2 ++ "E iv bf) ib' = packageIterateProcedure EXPR_" ++ cty1 ++ " EXPR_" ++ cty2 ++ " ib' (RemBind" ++ ty1  ++ " ib') iv bf\n"

genParseIf :: (String, String) -> String
genParseIf (tyn1, tyn2) =
      "parseQueryResult (IfThenElse" ++ tyn1 ++ tyn2 ++ " _ _ _) (IfThenElse" ++ tyn2 ++ "Reply r) = Just $ ExprRight $ lit r\n" ++
      "parseQueryResult (IfThenElse" ++ tyn1 ++ tyn2 ++ " _ _ _) (IfThenElse" ++ tyn1 ++ "LeftReply r) = Just $ ExprLeft $ lit r\n"

genParseIter :: (String, String) -> String
genParseIter (tyn1,tyn2) =
      "parseQueryResult (Iterate" ++ tyn1 ++ tyn2 ++ "E _ _) (Iterate" ++ tyn2 ++
      if tyn2 == "Unit" then "Reply) = Just $ LitUnit\n" else "Reply r) = Just $ lit r\n"

genCommProcIf :: (String, String) -> String
genCommProcIf (tyn1, tyn2) =
      "              , \"ifThenElse" ++ tyn1 ++ tyn2 ++ "\"\n"

genCommProcIter :: (String, String) -> String
genCommProcIter (tyn1, tyn2) =
      "              , \"iterate" ++ tyn1 ++ tyn2 ++ "E\"\n"

main :: IO ()
main = do
  let prims1 = map genEitherPrim typeNameTypeCombos
  let prims2 = map genIteratePrim typeNameTypeCombos
  let class1 = map genIterateInst typeNameTypeCombos
  let showIfs = map genShowIf typeNameTypeCombos
  let showIters = map genShowIter typeNameBindCombos
  let compIfs = map genCompIf typeNameCompTypeCombos
  let compIters = map genCompIter typeNameBindCompTypeCombos
  let packIfs = map genPackIf typeNameBindCombos
  let packIters = map genPackIter typeNameBindCombos
  let packageIfs = map genPackageIf typeNamePackTypeCombos
  let packageIters = map genPackageIter typeNameBindPackTypeCombos
  let parseIfs = map genParseIf typeNameCombos
  let parseIters = map genParseIter typeNameCombos
  let commProcIfs = map genCommProcIf typeNameCombos
  let commProcIters = map genCommProcIter typeNameCombos
  putStrLn $ concat prims1
  putStrLn ""
  putStrLn $ concat prims2
  putStrLn ""
  putStrLn $ concat class1
  putStrLn ""
  putStrLn $ concat showIfs
  putStrLn ""
  putStrLn $ concat showIters
  putStrLn ""
  putStrLn $ concat compIfs
  putStrLn ""
  putStrLn $ concat compIters
  putStrLn ""
  putStrLn $ concat packIfs
  putStrLn ""
  putStrLn $ concat packIters
  putStrLn ""
  putStrLn $ concat packageIfs
  putStrLn ""
  putStrLn $ concat packageIters
  putStrLn ""
  putStrLn $ concat parseIfs
  putStrLn ""
  putStrLn $ concat parseIters
  putStrLn ""
  putStrLn $ concat commProcIfs
  putStrLn ""
  putStrLn $ concat commProcIters
