text:
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}

{-# OPTIONS_GHC -Wall #-}

module CodeGen.C
  where

import           Deep.Expr

import           Data.Typeable

import           Data.Semigroup
import           Control.Monad.Writer
import           Control.Monad.State
import           Data.List

import           Data.Map (Map)
import qualified Data.Map as Map

import qualified Data.Set as Set

import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE

import           Data.Maybe (isNothing)

import           GHC.Stack (HasCallStack)

import           Data.Ord

import           Data.Complex

import           CodeGen.C.Types
import           CodeGen.C.Helper

import Debug.Trace

nub' :: Ord a => [a] -> [a]
nub' = Set.toList . Set.fromList

deleteAll :: Eq a => a -> [a] -> [a]
deleteAll _ [] = []
deleteAll x (y:ys)
  | y == x    =     deleteAll x ys
  | otherwise = y : deleteAll x ys

data SomeName = forall a. Typeable a => SomeName (Name a)

-- | NOTE: This instance will only take the unique value into account, not
-- the type tag of the 'Name'.
instance Eq SomeName where
  (SomeName (Name a)) == (SomeName (Name b)) = a == b

instance Ord SomeName where
  compare (SomeName (Name a)) (SomeName (Name b)) = compare a b

instance Show SomeName where
  show (SomeName n) = show n

newtype LocalEnv = LocalEnv (Map Int CName) deriving Show

-- Takes a unique from a 'Name a' and gives back the current CName that
-- references it.
le_lookup :: HasCallStack => Int -> LocalEnv -> CName
le_lookup uniq (LocalEnv env) =
  case Map.lookup uniq env of
    Nothing -> error $ "le_lookup: Cannot find " ++ show uniq
    Just x  -> x

le_modifyName :: LocalEnv -> Int -> CName -> LocalEnv
le_modifyName (LocalEnv env) uniq cname = LocalEnv $ Map.insert uniq cname env

le_modifyNames :: LocalEnv -> [(Int, CName)] -> LocalEnv
le_modifyNames le [] = le
le_modifyNames (LocalEnv env) ((uniq, cname):changes) = le_modifyNames (LocalEnv (Map.insert uniq cname env)) changes

le_fromList :: [(Int, CName)] -> LocalEnv
le_fromList = LocalEnv . Map.fromList

le_initial :: Int -> LocalEnv
le_initial varCount = LocalEnv $ Map.fromList $ map (\n -> (n, "vars[" <> show n <> "]")) [0..varCount-1]

data CodeGenState =
  CodeGenState
    { cg_le :: LocalEnv
    , cg_currUniq :: Int
    , cg_lams :: [SomeLambda]
    }

newtype CodeGen a =
  CodeGen (State CodeGenState a)
  deriving (Functor, Applicative, Monad)

deriving instance MonadState CodeGenState CodeGen

cg_modifyName :: Int -> CName -> CodeGen ()
cg_modifyName uniq cname =
  modify (\cg -> cg { cg_le = le_modifyName (cg_le cg) uniq cname })

cg_modifyNames :: [(Int, CName)] -> CodeGen ()
cg_modifyNames changes =
  modify (\cg -> cg { cg_le = le_modifyNames (cg_le cg) changes })

cg_lookup :: HasCallStack => Int -> CodeGen CName
cg_lookup uniq =
  fmap (le_lookup uniq . cg_le) get

withLocalEnv :: LocalEnv -> CodeGen a -> CodeGen a
withLocalEnv newEnv m = do
  oldEnv <- fmap cg_le get
  modify (\cg -> cg { cg_le = newEnv })
  r <- m
  modify (\cg -> cg { cg_le = oldEnv })
  return r

freshCName :: CodeGen CName
freshCName = do
  uniq <- fmap cg_currUniq get

  modify (\cg -> cg { cg_currUniq = uniq+1 })

  return ("x" ++ show uniq)

lookupLambda :: Int -> CodeGen SomeLambda
lookupLambda uniq = do
  lams <- fmap cg_lams get

  case find (\(SomeLambda lam) -> getNameUniq (lambda_name lam) == uniq) lams of
    Nothing -> error "lookupLambda"
    Just x  -> return x

runTopLevelCodeGen :: Int -> [SomeLambda] -> CodeGen a -> a
runTopLevelCodeGen varCount lams (CodeGen m) =
  evalState m (CodeGenState { cg_le = le_initial varCount, cg_currUniq = 0, cg_lams = lams })

data Lambda a b
  = Lambda
    { lambda_fvs :: [SomeName] -- | Free variables. These must remain sorted by unique, in ascending order
    , lambda_name :: Name a -- | Lambdas are named by their argument name
      -- TODO: Should we have a [(SomeName, CName)] (possibly replacing
      -- lambda_fvs?)
    , lambda_body :: GPUExp b
    , lambda_isTailRec :: Bool
    }

data SomeLambda = forall a b. {- Typeable a => -} SomeLambda (Lambda a b)

getFVs :: GPUExp a -> [SomeName]
getFVs = (`execState` []) . go
  where
    go :: forall s. GPUExp s -> State [SomeName] ()
    go (Var n) = modify (SomeName n:)

    go (CaseExp x y) = go x *> go y
    go (ProdMatchExp x) = go x
    go (SumMatchExp x y) = go x *> go y
    go (NullaryMatch x) = go x
    go (OneSumMatch x) = go x
    go (OneProdMatch x) = go x
    go EmptyMatch = pure ()
    go FalseExp = pure ()
    go TrueExp = pure ()
    go (Repped {}) = pure ()
    go (Lam n x) = do
      go x
      modify (deleteAll (SomeName n))
    go (App f x) = go f *> go x
    go (Lit {}) = pure ()
    go (Add x y) = go x *> go y
    go (Sub x y) = go x *> go y
    go (Mul x y) = go x *> go y
    go (FromEnum x) = go x
    go (FromIntegral x) = go x
    go (Sqrt x) = go x
    go (Equal x y) = go x *> go y
    go (Lte x y) = go x *> go y
    go (Gt x y) = go x *> go y
    go (Not x) = go x
    go (LeftExp x) = go x
    go (RightExp x) = go x
    go (PairExp x y) = go x *> go y
    go (FstExp x) = go x
    go (SndExp x) = go x
    go (StepExp x) = go x
    go (DoneExp x) = go x
    go (IfThenElse x y z) = go x *> go y *> go z
    go (TailRec x) = go x
    go (Construct {}) = pure ()
    go (ConstructAp x y) = go x *> go y
    go (Ord x) = go x
    go (CharLit {}) = pure ()
    go UnitExp = pure ()
    go (ConstructRep x) = go x
    go (CastExp x) = go x

-- | Precondition: The maximum unique of all the variables must be
-- equal to the number of variables.
--
-- TODO: Eliminate this precondition.
--
getVarCount :: GPUExp a -> Int
getVarCount = getMax . execWriter . go
  where
    -- TODO: Abstract this traversal pattern
    go :: forall s. GPUExp s -> Writer (Max Int) ()
    go (Var (Name n)) = tell (Max n)

    go (CaseExp x y) = go x *> go y
    go (ProdMatchExp x) = go x
    go (SumMatchExp x y) = go x *> go y
    go (NullaryMatch x) = go x
    go (OneSumMatch x) = go x
    go (OneProdMatch x) = go x
    go EmptyMatch = pure ()
    go FalseExp = pure ()
    go TrueExp = pure ()
    go (Repped {}) = pure ()
    go (Lam n x) = go x
    go (App f x) = go f *> go x
    go (Lit {}) = pure ()
    go (Add x y) = go x *> go y
    go (Sub x y) = go x *> go y
    go (Mul x y) = go x *> go y
    go (FromEnum x) = go x
    go (FromIntegral x) = go x
    go (Sqrt x) = go x
    go (Equal x y) = go x *> go y
    go (Lte x y) = go x *> go y
    go (Gt x y) = go x *> go y
    go (Not x) = go x
    go (LeftExp x) = go x
    go (RightExp x) = go x
    go (PairExp x y) = go x *> go y
    go (FstExp x) = go x
    go (SndExp x) = go x
    go (StepExp x) = go x
    go (DoneExp x) = go x
    go (IfThenElse x y z) = go x *> go y *> go z
    go (TailRec x) = go x
    go (Construct {}) = pure ()
    go (ConstructAp x y) = go x *> go y
    go (Ord x) = go x
    go (CharLit {}) = pure ()
    go UnitExp = pure ()
    go (ConstructRep x) = go x
    go (CastExp x) = go x

collectLambdas :: GPUExp a -> [SomeLambda]
collectLambdas = execWriter . go
  where
    go :: forall s. GPUExp s -> Writer [SomeLambda] ()
    go (Var {}) = pure ()
    go (CaseExp x y) = go x *> go y
    go (ProdMatchExp x) = go x
    go (SumMatchExp x y) = go x *> go y
    go (NullaryMatch x) = go x
    go (OneSumMatch x) = go x
    go (OneProdMatch x) = go x
    go EmptyMatch = pure ()
    go FalseExp = pure ()
    go TrueExp = pure ()
    go (Repped {}) = pure ()
    go (TailRec lamExp@(Lam n body)) = tell [mkLambda True (SomeName n) body] *> go body
    go (Lam n x) = tell [mkLambda False (SomeName n) x] *> go x
    go (App f x) = go f *> go x
    go (Lit {}) = pure ()
    go (Add x y) = go x *> go y
    go (Sub x y) = go x *> go y
    go (Mul x y) = go x *> go y
    go (FromEnum x) = go x
    go (FromIntegral x) = go x
    go (Sqrt x) = go x
    go (Equal x y) = go x *> go y
    go (Lte x y) = go x *> go y
    go (Gt x y) = go x *> go y
    go (Not x) = go x
    go (LeftExp x) = go x
    go (RightExp x) = go x
    go (PairExp x y) = go x *> go y
    go (FstExp x) = go x
    go (SndExp x) = go x
    go (StepExp x) = go x
    go (DoneExp x) = go x
    go (IfThenElse x y z) = go x *> go y *> go z
    go (TailRec x) = go x
    go (Construct {}) = pure ()
    go (ConstructAp x y) = go x *> go y
    go (Ord x) = go x
    go (CharLit {}) = pure ()
    go UnitExp = pure ()
    go (ConstructRep x) = go x
    go (CastExp x) = go x

mkLambda :: Bool -> SomeName -> GPUExp a -> SomeLambda
mkLambda isTailRec (SomeName argName) body =
  SomeLambda $
    Lambda
      { lambda_fvs = trace "lambda_fvs:" $ traceShowId $
          nub' $
          sortBy (comparing (\(SomeName a) -> getNameUniq a)) $
          deleteAll
            (SomeName argName)
            (getFVs body)
      , lambda_name = argName
      , lambda_body = body
      , lambda_isTailRec = isTailRec
      }

genProgram :: HasCallStack => GPUExp a -> CCode
genProgram e =
  let varCount = getVarCount e
      lambdas = collectLambdas e
  in
  runTopLevelCodeGen varCount lambdas $ do

    resultName <- freshCName

    lambdasCode <- genLambdas e
    exprCode <- genExp e resultName
    return $ unlines
      [ prelude varCount
      , unlines
          (map (\(SomeLambda lam) -> "var_t " <> lambdaCName_byInt (getNameUniq (lambda_name lam)) <> "(var_t, struct closure_t*);")
               lambdas)
      , ""
      , lambdasCode
      , "var_t top_level() {"
      , "  var_t " <> resultName <> ";"
      , exprCode
      , "  return " <> resultName <> ";"
      , "}"
      ]

prelude :: Int -> CCode
prelude varCount =
  unlines
    [ "#include <stdio.h>"
    , "#include <stdlib.h>"
    , "#include <stdbool.h>"
    , "#include <string.h>"
    , "#include <assert.h>"
    , "#include <math.h>"
    , ""
    , "typedef enum var_type_tag {"
    , "  EXPR_INT"
    , ", EXPR_FLOAT"
    , ", EXPR_DOUBLE"
    , ", EXPR_CHAR"
    , ", EXPR_BOOL"
    , ", EXPR_CLOSURE"
    , ", EXPR_EITHER_LEFT"
    , ", EXPR_EITHER_RIGHT"
    , ", EXPR_PAIR"
    , ", EXPR_UNIT"
    , ", EXPR_STEP"
    , ", EXPR_DONE"
    -- , ", EXPR_UNBOXED"
    , ", EXPR_NIL"
    , "} var_type_tag;"
    , ""
    , "typedef enum semantic_type_tag {"
    , "  NO_SEMANTIC_TAG"
    , ", EXPR_COMPLEX     // Complex numbers"
    , "} semantic_type_tag;"
    , ""
    , "struct closure_t;"
    , ""
    , "typedef struct var_t {"
    , "  var_type_tag tag;"
    , "  semantic_type_tag semantic_tag;  // For optional additional information about the \"un-deconstructed\" type (for instance, it could be the case that tag=EXPR_PAIR, but specific_tag=EXPR_COMPLEX)"
    , "  void* value;"
    , "} var_t;"
    , ""
    , "typedef struct closure_t {"
    , "  int env_size;"
    , "  var_t* fv_env;"
    , "  var_t (*fn)(var_t, struct closure_t*);"
    , "} closure_t;"
    , ""
    , "void copyClosure(closure_t*, closure_t*);"
    , ""
    , "void copyVar(var_t* dest, var_t* src) {"
    , "  dest->tag = src->tag;"
    , "  dest->semantic_tag = src->semantic_tag;"
    , "  if (src->tag == EXPR_PAIR) {"
    , "    dest->value = malloc(2*sizeof(var_t));"
    , "    copyVar(&((var_t*)dest->value)[0], &((var_t*)src->value)[0]);"
    , "    copyVar(&((var_t*)dest->value)[1], &((var_t*)src->value)[1]);"
    , "  } else {"
    , "    switch (src->tag) {"
    , "      case EXPR_INT:"
    , "       dest->value = malloc(sizeof(int));"
    , "       *(int*)(dest->value) = *(int*)(src->value);"
    , "       break;"
    , "      case EXPR_FLOAT:"
    , "       dest->value = malloc(sizeof(float));"
    , "       *(float*)(dest->value) = *(float*)(src->value);"
    , "       break;"
    , "      case EXPR_DOUBLE:"
    , "       dest->value = malloc(sizeof(double));"
    , "       *(double*)(dest->value) = *(double*)(src->value);"
    , "       break;"
    , "      case EXPR_CHAR:"
    , "       dest->value = malloc(sizeof(char));"
    , "       *(char*)(dest->value) = *(char*)(src->value);"
    , "       break;"
    , "      case EXPR_CLOSURE:"
    , "       dest->value = malloc(sizeof(closure_t));"
    -- , "       *(closure_t*)(dest->value) = *(closure_t*)(src->value);"
    , "       copyClosure((closure_t*)dest->value, (closure_t*)src->value);"
    , "       break;"
    , "      case EXPR_EITHER_LEFT:"
    , "      case EXPR_EITHER_RIGHT:"
    , "      case EXPR_STEP:"
    , "      case EXPR_DONE:"
    , "      case EXPR_UNIT:"
    , "       dest->value = malloc(sizeof(var_t));"
    , "       copyVar((var_t*)(dest->value), (var_t*)(src->value));"
    -- , "       *(var_t*)(dest->value) = *(var_t*)(src->value);"
    , "       break;"
    , "      case EXPR_NIL:"
    , "       dest->value = NULL;"
    , "       break;"
    , "      default:"
    , "        assert(0 && \"invalid tag\");"
    , "    }"
    , "  }"
    , "}"
    , ""
    , "void copyClosure(closure_t* dest, closure_t* src) {"
    , "  dest->env_size = src->env_size;"
    , "  dest->fn = src->fn;"
    , "  dest->fv_env = malloc(src->env_size * sizeof(var_t));"
    , "  for (int i = 0; i < src->env_size; ++i) {"
    , "    copyVar(&(dest->fv_env[i]), &(src->fv_env[i]));"
    , "  }"
    , "}"
    , ""
    , "var_t car(var_t v) {"
    , "  return ((var_t*)v.value)[0];"
    , "}"
    , "var_t cdr(var_t v) {"
    , "  return ((var_t*)v.value)[1];"
    , "}"
    , ""
    , "var_t vars[" <> show varCount <> "];"
    , ""
    , "#define GET_MATH_OP_ADD +"
    , "#define GET_MATH_OP_MUL *"
    , "#define GET_MATH_OP_SUB -"
    , "#define GET_MATH_OP_DIV /"
    , ""
    , "#define GET_COMPARE_OP_LTE <="
    , "#define GET_COMPARE_OP_LT <"
    , "#define GET_COMPARE_OP_GTE >="
    , "#define GET_COMPARE_OP_GT >"
    , "#define GET_COMPARE_OP_EQUAL =="
    , ""
    , "#define assert_msg(cond, msg) do { if (!(cond)) { printf msg; assert(0 && #cond); } } while(0)"
    , ""
    , "#define MATH_OP(op, result, a, b)\\"
    , "  do {\\"
    , "    assert_msg((a).tag == (b).tag, (\"(a,b).tag = (%i,%i)\\n\", (int)(a).tag, (int)(b).tag));\\"
    , "    (result).semantic_tag = (a).semantic_tag;\\"
    , "    (result).tag = (a).tag;\\"
    , "    switch ((a).tag) {\\"
    , "      case EXPR_INT:\\"
    , "        (result).value = malloc(sizeof(int));\\"
    , "        *((int*)(result).value) = *(int*)((a).value) GET_MATH_OP_##op *(int*)((b).value);\\"
    , "        break;\\"
    , "      case EXPR_FLOAT:\\"
    , "        (result).value = malloc(sizeof(float));\\"
    , "        *((float*)(result).value) = *(float*)((a).value) GET_MATH_OP_##op *(float*)((b).value);\\"
    , "        break;\\"
    , "      case EXPR_DOUBLE:\\"
    , "        (result).value = malloc(sizeof(double));\\"
    , "        *((double*)(result).value) = *(double*)((a).value) GET_MATH_OP_##op *(double*)((b).value);\\"
    , "        break;\\"
    , "      default:\\"
    , "        fprintf(stderr, \"%s type tag = %d\\n\", #a, (a).tag);\\"
    , "        assert(0 && \"Attempting to perform arithmetic on non-numeric types\");\\"
    , "    }\\"
    , "  } while (0);"
    , ""
    , "#define COMPARE(op, result, a, b)\\"
    , "  do {\\"
    , "   assert((a).tag == (b).tag);\\"
    , "    switch ((a).tag) {\\"
    , "      case EXPR_INT:\\"
    , "        *((bool*)(result).value) = *(int*)((a).value) GET_COMPARE_OP_##op *(int*)((b).value);\\"
    , "        break;\\"
    , "      case EXPR_FLOAT:\\"
    , "        *((bool*)(result).value) = *(float*)((a).value) GET_COMPARE_OP_##op *(float*)((b).value);\\"
    , "        break;\\"
    , "      case EXPR_DOUBLE:\\"
    , "        *((bool*)(result).value) = *(double*)((a).value) GET_COMPARE_OP_##op *(double*)((b).value);\\"
    , "        break;\\"
    , "      case EXPR_BOOL:\\"
    , "        *((bool*)(result).value) = *(bool*)((a).value) GET_COMPARE_OP_##op *(bool*)((b).value);\\"
    , "        break;\\"
    , "      case EXPR_CHAR:\\"
    , "        *((bool*)(result).value) = *(char*)((a).value) GET_COMPARE_OP_##op *(char*)((b).value);\\"
    , "        break;\\"
    , "      default:\\"
    , "        fprintf(stderr, \"%s type tag = %d\\n\", #a, (a).tag);\\"
    , "        assert(0 && \"Cannot compare given type for equality\");\\"
    , "    }\\"
    , "  } while (0);"
    , ""
    , "#define CAST_TO(result, r_type, a)\\"
    , "  do {\\"
    , "    switch ((a).tag) {\\"
    , "      case EXPR_INT:\\"
    , "        *((r_type*)(result).value) = (r_type) *(int*)((a).value);\\"
    , "        break;\\"
    , "      case EXPR_FLOAT:\\"
    , "        *((r_type*)(result).value) = (r_type) *(float*)((a).value);\\"
    , "        break;\\"
    , "      case EXPR_DOUBLE:\\"
    , "        *((r_type*)(result).value) = (r_type) *(double*)((a).value);\\"
    , "        break;\\"
    , "      default:\\"
    , "        fprintf(stderr, \"%s type tag = %d\\n\", #a, (a).tag);\\"
    , "        assert(0 && \"CAST_FROM: Invalid type tag\");\\"
    , "    }\\"
    , "  } while (0);"
    , ""
    , "#define MATH_SQRT(result, a)\\"
    , "  do {\\"
    , "      case EXPR_FLOAT:\\"
    , "        *((float*)(result).value) = sqrt(*(float*)((a).value));\\"
    , "        break;\\"
    , "      case EXPR_DOUBLE:\\"
    , "        *((double*)(result).value) = sqrt(*(double*)((a).value));\\"
    , "        break;\\"
    , "  } while(0);"
    , ""
    , "#define INIT_COMPLEX_PAIR(result)\\"
    , "  do {\\"
    , "    (result).semantic_tag = EXPR_COMPLEX;\\"
    , "    (result).tag = EXPR_PAIR;\\"
    , "    (result).value = malloc(2*sizeof(var_t));\\"
    , "    ((var_t*)((result).value))[1].value = malloc(2*sizeof(var_t));\\"
    , "  } while (0);"
    , ""
    , "#define INIT_COMPLEX(a, type, eTag)\\"
    , "  do {\\"
    , "    (a).semantic_tag = EXPR_COMPLEX;\\"
    , "    (a).tag = EXPR_PAIR;\\"
    , "    (a).value = malloc(2*sizeof(var_t));\\"
    , "    ((var_t*)((a).value))[0].tag = eTag;\\"
    , "    ((var_t*)((a).value))[0].value = malloc(sizeof(var_t));\\"

    , "    ((var_t*)((a).value))[1].tag = EXPR_PAIR;\\"
    , "    ((var_t*)((a).value))[1].semantic_tag = NO_SEMANTIC_TAG;\\"
    , "    ((var_t*)((a).value))[1].value = malloc(2*sizeof(var_t));\\"

    , "    ((var_t*)((var_t*)((a).value))[1].value)[0].tag = eTag;\\"
    , "    ((var_t*)((var_t*)((a).value))[1].value)[0].semantic_tag = NO_SEMANTIC_TAG;\\"
    , "    ((var_t*)((var_t*)((a).value))[1].value)[0].value = malloc(sizeof(var_t));\\"

    , "    ((var_t*)((var_t*)((a).value))[1].value)[1].tag = EXPR_NIL;\\"
    , "    ((var_t*)((var_t*)((a).value))[1].value)[1].semantic_tag = NO_SEMANTIC_TAG;\\"
    , "    ((var_t*)((var_t*)((a).value))[1].value)[1].value = NULL;\\"

    -- , "    ((var_t*)((a).value))[1].tag = eTag;\\"
    -- , "    ((var_t*)((a).value))[1].value = malloc(sizeof(var_t));\\"
    , "  } while (0);"
    , ""
    , "#define PAIR_FST(result, p)\\"
    , "  do {\\"
    , "    assert((p).tag == EXPR_PAIR);\\"
    , "    " <> stmt (cCall "copyVar" [addrOf "result", addrOf (cCast "var_t*" ("(p)" # "value") ! 0)]) <> "\\"
    -- , "    (result) = ((var_t*)((p).value))[0];\\"
    , "  } while(0);"
    , ""
    , "#define PAIR_SND(result, p)\\"
    , "  do {\\"
    , "    assert((p).tag == EXPR_PAIR);\\"
    , "    " <> stmt (cCall "copyVar" [addrOf "result", addrOf (cCast "var_t*" ((cCast "var_t*" ("(p)" # "value") ! 1) # "value") ! 0)]) <> "\\"
    -- , "    (result) = ((var_t*)((var_t*)((result).value))[1].value)[0];\\"
    , "  } while(0);"
    , ""
    , "#define PAIR_ASSIGN_FST(result, x)\\"
    , "  do {\\"
    , "    " <> stmt (cCall "copyVar" [addrOf (cCast "var_t*" ("(result)" # "value") ! 0), addrOf "x"]) <> "\\"
    -- , "    ((var_t*)((result).value))[0] = (x);\\"
    , "  } while(0);"
    , ""
    , "#define PAIR_ASSIGN_SND(result, x)\\"
    , "  do {\\"
    , "    " <> stmt (cCall "copyVar" [addrOf (cCast "var_t*" ((cCast "var_t*" ("(result)" # "value") ! 1) # "value") ! 0), addrOf "x"]) <> "\\"
    -- , "    ((var_t*)((var_t*)((result).value))[1].value)[0] = (x); \\"
    , "  } while(0);"
    , ""
    , "#define GET_COMPLEX_REAL(c) ((var_t*)((c).value))[0]"
    , "#define GET_COMPLEX_IMAG(c) ((var_t*)((var_t*)((c).value))[1].value)[0]"
    , ""
    , "#define COMPLEX_REAL(result, c)\\"
    , "  do {\\"
    , "    assert((p).semantic_tag == EXPR_COMPLEX);\\"
    , "    PAIR_FST(result, c);\\"
    , "  } while (0);"
    , ""
    , "#define COMPLEX_IMAG(result, c)\\"
    , "  do {\\"
    , "    assert((c).semantic_tag == EXPR_COMPLEX);\\"
    , "    PAIR_SND(result, c);\\"
    , "  } while (0);"
    , ""
    , "#define COMPLEX_ASSIGN_REAL(result, x)\\"
    , "  do {\\"
    , "    PAIR_ASSIGN_FST(result, x);\\"
    , "  } while(0);"
    , ""
    , "#define COMPLEX_ASSIGN_IMAG(result, x)\\"
    , "  do {\\"
    , "    PAIR_ASSIGN_SND(result, x);\\"
    , "  } while(0);"
    , ""
    , "bool isIterTag(var_type_tag tag) {"
    , "  return tag == EXPR_STEP || tag == EXPR_DONE;"
    , "}"
    ]

data ShowablePair = forall a. (Typeable a, Show a) => ShowablePair a a

mainCode :: [CCode] -> CCode
mainCode body =
  unlines
    [ "int main(int argc, char* argv[]) {"
    , unlines (map (++"  ") body)
    , "}"
    ]

genExp :: HasCallStack => GPUExp a -> CName -> CodeGen CCode

genExp (ConstructRep x :: GPUExp t) resultName =
  case getComplexType_maybe (Proxy :: Proxy t) of
    Nothing -> do
      r <- genExp x resultName
      return $ unlines
        [ "// ConstructRep (Non-Complex)"
        , r
        ]

    Just (ty, tag) -> do
      pairName <- freshCName
      pairCode <- genExp x pairName

      return $ unlines
        [ "// Complex ConstructRep"
        , "var_t " <> pairName <> ";"
        , pairCode

        -- , (resultName#"value") =: cCall "malloc" ["2*sizeof(var_t)"]
        , cCall "INIT_COMPLEX" [resultName, ty, tag]
        , resultName <> ".semantic_tag = EXPR_COMPLEX;"
        , resultName <> ".tag = EXPR_PAIR;"
        , cCall "COMPLEX_ASSIGN_REAL" [resultName, cCall "GET_COMPLEX_REAL" [pairName]]
        , cCall "COMPLEX_ASSIGN_IMAG" [resultName, cCall "GET_COMPLEX_IMAG" [pairName]]

        -- , cCall "COMPLEX_ASSIGN_REAL" [resultName, (cCast "var_t*" (pairName # "value")) ! 0]
        -- , cCall "COMPLEX_ASSIGN_IMAG" [resultName, (cCast "var_t*" (pairName # "value")) ! 1]

        -- , "COMPLEX_ASSIGN_REAL(" <> resultName <> ", " <> pairName <> "
        -- , resultName <> ".value = malloc(sizeof(var_t));"

        -- , stmt $ cCall "copyVar" [cCast "var_t*" (resultName # "value"), addrOf pairName]

        -- , "*((var_t*)(" <> resultName <> ".value)) = " <> pairName <> ";"

        ]

genExp (Var name@(Name n)) resultName = do
  nCName <- cg_lookup n

  return $ unlines
    [ "  // Var with Name id " <> show n <> " and Haskell type " <> show (typeRep name)
    , "if (isIterTag(" <> nCName <> ".tag)) {"
    , stmt $ cCall "copyVar" [addrOf resultName, cCast "var_t*" (nCName # "value")]
    , "} else {"
    , stmt $ cCall "copyVar" [addrOf resultName, addrOf nCName]
    , "}"

    -- , "if (isIterTag(" <> nCName <> ".tag)) {"
    -- , resultName <> " = " <> "*(var_t*)(" <> nCName <> ".value);"
    -- , "} else {"
    -- , resultName <> " = " <> nCName <> ";"
    -- , "}"
    ]

genExp (CaseExp s body) resultName = do
  sResultName <- freshCName
  computeS <- genExp s sResultName

  caseCode <- genCaseExp sResultName body resultName

  return $ unlines
    [ "var_t " <> sResultName <> ";"
    , computeS
    , caseCode
    ]

genExp (Lam (Name n) body) resultName = do
  closurePtrName <- freshCName

  sLam@(SomeLambda lam) <- lookupLambda n
  closureCode <- buildClosure sLam ("(*" <> closurePtrName <> ")")

  -- let fvs = lambda_fvs lam

  return $ unlines
    [ "closure_t* " <> closurePtrName <> " = malloc(sizeof(closure_t));"
    , closureCode
    , ""
    , resultName <> ".tag = EXPR_CLOSURE;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = (void*)" <> closurePtrName <> ";"
    ]

genExp (ProdMatchExp f) resultName = genExp f resultName

genExp (OneProdMatch f) resultName = genExp f resultName

-- TODO: Generalize
genExp (App lamExp@(Lam (Name n) _) x) resultName = do
  xName <- freshCName
  xCode <- genExp x xName

  le <- fmap cg_le get

  traceM $ "/////////// le = " ++ show le
  traceM $ "/////////// le' = " ++ show (le_modifyName le n xName)

  closureName <- freshCName
  closureVarName <- freshCName
  closureCode <- withLocalEnv (le_modifyName le n xName) $ genExp lamExp closureVarName

  lam <- lookupLambda n

  callCode <- callClosure lam closureName xName resultName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , "closure_t " <> closureName <> ";"
    , "var_t " <> closureVarName <> ";"
    , ""
    , xCode
    , closureCode
    , "copyClosure(&" <> closureName <> ", (closure_t*)(" <> closureVarName <> ".value));"
    , callCode
    ]

genExp (App (TailRec lam) x) resultName = genExp (App lam x) resultName

genExp (App _ _) _ = error "genExp: App"

-- genExp (App f x) resultName = do
--   rName <- freshCName
--   xName <- freshCName

--   rCode <- genExp f fName
--   xCode <- genExp x xName

--   callCode <- callClosure

--   return $ unlines
--     [ "var_t " <> fName <> ";"
--     , "var_t " <> xName <> ";"
--     ,

genExp (Lit x :: GPUExp t) resultName =
    case getComplex_maybe x of
      Just (ShowablePair a b, (ty, tag)) -> do
        aName <- freshCName
        bName <- freshCName

        aCode <- oneDimNumCode a aName ty tag
        bCode <- oneDimNumCode b bName ty tag

        return $ unlines
          [ "var_t " <> aName <> ";"
          , "var_t " <> bName <> ";"
          , aCode
          , bCode
          , "// Complex Lit"
          , "INIT_COMPLEX(" <> resultName <> ", " <> ty <> ", " <> tag <> ");"
          , "COMPLEX_ASSIGN_REAL(" <> resultName <> ", " <> aName <> ");"
          , "COMPLEX_ASSIGN_IMAG(" <> resultName <> ", " <> bName <> ");"
          -- , resultName <> ".value = malloc(sizeof(2*sizeof(var_t)));"
          -- , resultName <> ".tag = " <> tag <> ";"
          -- , resultName <> ".value[0] = " <> "*(" <> ty <> ")(" <> aName <> ".value);"
          -- , resultName <> ".value[1] = " <> "*(" <> ty <> ")(" <> bName <> ".value);"
          ]
      Nothing ->
        uncurry (oneDimNumCode x resultName) (numTypeInfo x)
  where

    oneDimNumCode x' resultName' ty tag =
      return $ unlines
        [ "// oneDimNumCode"
        , resultName' <> ".value = malloc(sizeof(" <> ty <> "));"
        , resultName' <> ".tag = " <> tag <> ";"
        , resultName' <> ".semantic_tag = NO_SEMANTIC_TAG;"
        , "*(" <> ty <>"*)(" <> resultName' <> ".value) = " <> show x' <> ";"
        ]

genExp TrueExp resultName =
  return $ unlines
    [ resultName <> ".tag = EXPR_BOOL;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(bool));"
    , "*(bool*)(" <> resultName <> ".value) = true;"
    ]

genExp FalseExp resultName =
  return $ unlines
    [ resultName <> ".tag = EXPR_BOOL;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(bool));"
    , "*(bool*)(" <> resultName <> ".value) = false;"
    ]

genExp (DoneExp x) resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , xCode
    , resultName <> ".tag = EXPR_DONE;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(var_t));"
    , stmt $ cCall "copyVar" [cCast "var_t*" (resultName # "value"), addrOf xName]
    -- , "*(var_t*)(" <> resultName <> ".value) = " <> xName <> ";"
    ]

genExp (StepExp x) resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , xCode
    , resultName <> ".tag = EXPR_STEP;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(var_t));"
    , stmt $ cCall "copyVar" [cCast "var_t*" (resultName # "value"), addrOf xName]
    -- , "*(var_t*)(" <> resultName <> ".value) = " <> xName <> ";"
    ]

genExp (Sub x y) resultName = do -- TODO: Fix complex number support (see Add)
  xName <- freshCName
  yName <- freshCName

  xCode <- genExp x xName
  yCode <- genExp y yName

  return $ unlines
    [ "// Sub"
    , "var_t " <> xName <> ";"
    , "var_t " <> yName <> ";"
    , xCode
    , yCode
    , "assert(" <> xName <> ".tag == " <> yName <> ".tag);"
    , ""
    , "if (" <> xName <> ".semantic_tag == EXPR_COMPLEX) {"
    , "  INIT_COMPLEX_PAIR(" <> resultName <> ");"
    , "  MATH_OP(SUB, GET_COMPLEX_REAL(" <> resultName <> "), GET_COMPLEX_REAL(" <> xName <> "), GET_COMPLEX_REAL(" <> yName <> "));"
    , "  MATH_OP(SUB, GET_COMPLEX_IMAG(" <> resultName <> "), GET_COMPLEX_IMAG(" <> xName <> "), GET_COMPLEX_IMAG(" <> yName <> "));"
    -- , "  MATH_OP(SUB, GET_COMPLEX_IMAG(" <> resultName <> "), ((var_t*)(" <> xName <> ".value))[1], ((var_t*)(" <> yName <> ".value)[1]); "
    , "} else {"
    , "  MATHOP(SUB, " <> resultName <> ", " <> xName <> ", " <> yName <> ");"
    , "}"
    ]

genExp (Mul x y) resultName = do
  xName <- freshCName
  yName <- freshCName

  x0y0Name <- freshCName
  x0y1Name <- freshCName
  x1y0Name <- freshCName
  x1y1Name <- freshCName

  realName <- freshCName
  imagName <- freshCName

  xCode <- genExp x xName
  yCode <- genExp y yName

  return $ unlines
    [ "// Mul"
    , "var_t " <> xName <> ";"
    , "var_t " <> yName <> ";"
    , xCode
    , yCode
    -- , "assert(" <> xName <> ".tag == " <> yName <> ".tag);"
    , ""
    , "if (" <> xName <> ".semantic_tag == EXPR_COMPLEX) {"
    , "  var_t " <> x0y0Name <> ";"
    , "  var_t " <> x0y1Name <> ";"
    , "  var_t " <> x1y0Name <> ";"
    , "  var_t " <> x1y1Name <> ";"
    , "  var_t " <> realName <> ";"
    , "  var_t " <> imagName <> ";"
    , ""
    , "  MATH_OP(MUL, " <> x0y0Name <> ", GET_COMPLEX_REAL(" <> xName <> "), GET_COMPLEX_REAL(" <> yName <> "));"
    , "  MATH_OP(MUL, " <> x0y1Name <> ", GET_COMPLEX_REAL(" <> xName <> "), GET_COMPLEX_IMAG(" <> yName <> "));"
    , "  MATH_OP(MUL, " <> x1y0Name <> ", GET_COMPLEX_IMAG(" <> xName <> "), GET_COMPLEX_REAL(" <> yName <> "));"
    , "  MATH_OP(MUL, " <> x1y1Name <> ", GET_COMPLEX_IMAG(" <> xName <> "), GET_COMPLEX_IMAG(" <> yName <> "));"
    -- , "  MATH_OP(MUL, " <> x0y0Name <> ", ((var_t*)(" <> xName <> ".value))[0], ((var_t*)(" <> yName <> ".value))[0]);"
    -- , "  MATH_OP(MUL, " <> x0y1Name <> ", ((var_t*)(" <> xName <> ".value))[0], ((var_t*)(" <> yName <> ".value))[1]);"
    -- , "  MATH_OP(MUL, " <> x1y0Name <> ", ((var_t*)(" <> xName <> ".value))[1], ((var_t*)(" <> yName <> ".value))[0]);"
    -- , "  MATH_OP(MUL, " <> x1y1Name <> ", ((var_t*)(" <> xName <> ".value))[1], ((var_t*)(" <> yName <> ".value))[1]);"
    , ""
    , "  MATH_OP(SUB, " <> realName <> ", " <> x0y0Name <> ", " <> x1y1Name <> ");"
    , "  MATH_OP(ADD, " <> imagName <> ", " <> x0y1Name <> ", " <> x1y0Name <> ");"
    -- , "  assert(*(var_t*)(" <> realName <> ".value).tag == *(var_t*)(" <> imagName <> ".value).tag);"
    , "  INIT_COMPLEX_PAIR(" <> resultName <> ");"
    , "  COMPLEX_ASSIGN_REAL(" <> resultName <> ", " <> realName <> ");"
    , "  COMPLEX_ASSIGN_IMAG(" <> resultName <> ", " <> imagName <> ");"
    -- , "  ((var_t*)(" <> resultName <> ".value))[0] = *((var_t*)(" <> realName <> ".value));"
    -- , "  ((var_t*)(" <> resultName <> ".value))[1] = *((var_t*)(" <> imagName <> ".value));"
    , "} else {"
    , "  MATH_OP(MUL, " <> resultName <> ", " <> xName <> ", " <> yName <> ");"
    , "}"
    ]

genExp (Add x y) resultName = do
  xName <- freshCName
  yName <- freshCName

  complexPairNameX <- freshCName
  complexPairNameY <- freshCName

  realResultName <- freshCName
  imagResultName <- freshCName

  xCode <- genExp x xName
  yCode <- genExp y yName

  return $ unlines
    [ "// Add"
    , "var_t " <> xName <> ";"
    , "var_t " <> yName <> ";"
    , "var_t " <> complexPairNameX <> ";"
    , "var_t " <> complexPairNameY <> ";"
    , "var_t " <> realResultName <> ";"
    , "var_t " <> imagResultName <> ";"
    , xCode
    , yCode
    , "assert(" <> xName <> ".tag == " <> yName <> ".tag);"
    , ""
    , "if (" <> xName <> ".semantic_tag == EXPR_COMPLEX) {"
    , "  INIT_COMPLEX_PAIR(" <> resultName <> ");"
    , ""
    -- , "  MATH_OP(ADD, " <> realResultName <> ", ((var_t*)(" <> xName <> ".value))[0], ((var_t*)(" <> yName <> ".value))[0]);"
    -- , "  MATH_OP(ADD, " <> imagResultName <> ", ((var_t*)(" <> xName <> ".value))[1], ((var_t*)(" <> yName <> ".value))[1]);"
    , "  MATH_OP(SUB, " <> realResultName <> ", GET_COMPLEX_REAL(" <> xName <> "), GET_COMPLEX_REAL(" <> yName <> "));"
    , "  MATH_OP(SUB, " <> imagResultName <> ", GET_COMPLEX_IMAG(" <> xName <> "), GET_COMPLEX_IMAG(" <> yName <> "));"
    , ""
    , "  COMPLEX_ASSIGN_REAL(" <> resultName <> ", " <> realResultName <> ");"
    , "  COMPLEX_ASSIGN_IMAG(" <> resultName <> ", " <> imagResultName <> ");"
    , "} else {"
    , "  MATH_OP(ADD, " <> resultName <> ", " <> xName <> ", " <> yName <> ");"
    , "}"
    ]

genExp (FromIntegral (x :: GPUExp a) :: GPUExp b) resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  case getComplexType_maybe (Proxy :: Proxy b) of
    Just (ty, tag) -> do

      let (tyX, tagX) = numTypeInfo (undefined :: a)

      zeroName <- freshCName

      castedXName <- freshCName

      return $ unlines
        [ "// Complex FromIntegral with ty = " <> ty
        , "var_t " <> xName <> ";"
        , "var_t " <> castedXName <> ";"
        , "var_t " <> zeroName <> ";"
        , zeroName <> ".tag = " <> tag <> ";"
        , zeroName <> ".semantic_tag = NO_SEMANTIC_TAG;"
        , zeroName <> ".value = malloc(sizeof(" <> ty <> "));"
        , "*((" <> ty <> "*)(" <> zeroName <> ".value)) = 0;"
        , xCode
        , castedXName <> ".tag = " <> tag <> ";"
        , castedXName <> ".semantic_tag = NO_SEMANTIC_TAG;"
        , castedXName <> ".value = malloc(sizeof(" <> ty <> "));"
        , "CAST_TO(" <> castedXName <> ", " <> ty <> ", " <> xName <> ");"
        -- , "*(" <> ty <> "*)(" <> castedXName <> ".value) = *(" <> ty <> "*)(" <> xName <> ".value);"
        , "INIT_COMPLEX(" <> resultName <> ", " <> ty <> ", " <> tag <> ");"
        , "COMPLEX_ASSIGN_REAL(" <> resultName <> ", " <> castedXName <> ");"
        , "COMPLEX_ASSIGN_IMAG(" <> resultName <> ", " <> zeroName <> ");"
        -- , resultName <> ".value = malloc(2*sizeof(var_t));"
        -- , "((var_t*)(" <> resultName <> ".value))[0] = " <> xName <> ";"
        -- , "*(" <> ty <> "*)(((var_t*)(" <> resultName <> ".value))[1].value) = 0;"
        ]
    Nothing -> do
      let (ty, tag) = numTypeInfo (undefined :: b)

      return $ unlines
        [ "var_t " <> xName <> ";"
        , xCode
        , ""
        , "CAST_TO(" <> resultName <> ", " <> ty <> ", " <> xName <> ");"
        ]

genExp (Sqrt x) resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , xCode
    , ""
    , "MATH_SQRT(" <> resultName <> ", " <> xName <>");"
    ]

genExp (Lte x y) resultName = do
  xName <- freshCName
  yName <- freshCName

  xCode <- genExp x xName
  yCode <- genExp y yName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , "var_t " <> yName <> ";"
    , xCode
    , yCode
    , "assert(" <> xName <> ".tag == " <> yName <> ".tag);"
    , resultName <> ".tag = EXPR_BOOL;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(bool));"
    , "COMPARE(LTE, " <> resultName <> ", " <> xName <> ", " <> yName <> ");"
    ]

genExp (Gt x y) resultName = do
  xName <- freshCName
  yName <- freshCName

  xCode <- genExp x xName
  yCode <- genExp y yName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , "var_t " <> yName <> ";"
    , xCode
    , yCode
    , "assert(" <> xName <> ".tag == " <> yName <> ".tag);"
    , resultName <> ".tag = EXPR_BOOL;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(bool));"
    , "COMPARE(GT, " <> resultName <> ", " <> xName <> ", " <> yName <> ");"
    ]

genExp (Equal x y) resultName = do
  xName <- freshCName
  yName <- freshCName

  xCode <- genExp x xName
  yCode <- genExp y yName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , "var_t " <> yName <> ";"
    , xCode
    , yCode
    , "assert(" <> xName <> ".tag == " <> yName <> ".tag);"
    , ""
    , resultName <> ".tag = EXPR_BOOL;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(bool));"
    , "if (" <> resultName <> ".tag == EXPR_COMPLEX) {"
    , "  COMPARE(EQUAL, " <> resultName <> ", ((var_t*)(" <> xName <> ".value))[0], ((var_t*)(" <> yName <> ".value))[0]);"
    , "  COMPARE(EQUAL, " <> resultName <> ", ((var_t*)(" <> xName <> ".value))[1], ((var_t*)(" <> yName <> ".value))[1]);"
    , "} else {"
    , "  COMPARE(EQUAL, " <> resultName <> ", " <> xName <> ", " <> yName <> ");"
    , "}"
    ]

genExp (IfThenElse b t f) resultName = do
  bName <- freshCName
  tName <- freshCName
  fName <- freshCName

  bCode <- genExp b bName
  tCode <- genExp t resultName
  fCode <- genExp f resultName

  return $ unlines
    [ "var_t " <> bName <> ";"
    , "var_t " <> tName <> ";"
    , "var_t " <> fName <> ";"
    , ""
    , bCode
    , ""
    , "if (*(bool*)(" <> bName <> ".value)) {"
    , tCode
    , "} else {"
    , fCode
    , "}"
    ]

genExp (TailRec lamExp@(Lam (Name n) body)) resultName = do
  genExp lamExp resultName

genExp (PairExp x y) resultName = do
  xName <- freshCName
  yName <- freshCName

  xCode <- genExp x xName
  yCode <- genCdr y yName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , "var_t " <> yName <> ";"
    , xCode
    , yCode
    , resultName <> ".tag = EXPR_PAIR;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(var_t)*2);"
    , stmt $ cCall "copyVar" [addrOf (cCast "var_t*" (resultName # "value") ! 0), addrOf xName]
    , stmt $ cCall "copyVar" [addrOf (cCast "var_t*" (resultName # "value") ! 1), addrOf yName]
    -- , "((var_t*)(" <> resultName <> ".value))[0] = " <> xName <> ";"
    -- , "((var_t*)(" <> resultName <> ".value))[1] = " <> yName <> ";"
    ]

genExp (Repped x) resultName = error "genExp: Repped" --genExp (rep x) resultName

genExp (LeftExp x) resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , xCode
    , resultName <> ".tag = EXPR_EITHER_LEFT;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(var_t));"
    , "*(var_t*)(" <> resultName <> ".value) = " <> xName <> ";"
    ]

genExp (RightExp x) resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , xCode
    , resultName <> ".tag = EXPR_EITHER_RIGHT;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(var_t));"
    , "*(var_t*)(" <> resultName <> ".value) = " <> xName <> ";"
    ]

genExp UnitExp resultName =
  return $ unlines
    [ resultName <> ".tag = EXPR_UNIT;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = 0;"
    ]

genExp (CharLit c) resultName =
  return $ unlines
    [ resultName <> ".tag = EXPR_CHAR;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , "*(char*)(" <> resultName <> ".value) = " <> show c <> ";"
    ]

genExp (Ord x) resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , xCode
    , ""
    , resultName <> ".tag = EXPR_INT;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , "*(int*)(" <> resultName <> ".value) = *(int*)(" <> xName <> ".value);"
    ]
genExp (CastExp x) resultName = genExp x resultName

genExp (FromEnum x) resultName = error "genExp: TODO: implement FromEnum"

genExp (SumMatchExp _ _) _ = error "genExp: SumMatchExp"
genExp (NullaryMatch _) _ = error "genExp: NullaryMatch"
genExp (OneSumMatch _) _ = error "genExp: OneSumMatch"
genExp EmptyMatch _ = error "genExp: EmptyMatch"

genCdr :: forall a. GPUExp a -> CName -> CodeGen CCode
genCdr x@(PairExp {}) resultName
  | Nothing <- eqT :: Maybe (a :~: Complex Double)
      = genExp x resultName
genCdr x resultName = do
  xName <- freshCName

  xCode <- genExp x xName

  return $ unlines
    [ "var_t " <> xName <> ";"
    , xCode
    , resultName <> ".tag = EXPR_PAIR;"
    , resultName <> ".semantic_tag = NO_SEMANTIC_TAG;"
    , resultName <> ".value = malloc(sizeof(var_t)*2);"
    -- , "((var_t*)(" <> resultName <> ".value))[0] = " <> xName <> ";"
    , stmt $ cCall "copyVar" [addrOf (cCast "var_t*" (resultName # "value") ! 0), addrOf xName]
    , "((var_t*)(" <> resultName <> ".value))[1].tag = EXPR_NIL;"
    , "((var_t*)(" <> resultName <> ".value))[1].semantic_tag = NO_SEMANTIC_TAG;"
    , "((var_t*)(" <> resultName <> ".value))[1].value = NULL;"
    ]

genCaseExp :: CName -> GPUExp (SumMatch a r) -> CName -> CodeGen CCode
genCaseExp s (CastExp x) resultName = genCaseExp s x resultName
genCaseExp s (OneSumMatch p) resultName = genProdMatch s p resultName
genCaseExp s (SumMatchExp x y) resultName = do
  s' <- freshCName

  thenPart <- genProdMatch s' x resultName
  elsePart <- genCaseExp s' y resultName

  return $ unlines
    [ "assert(" <> s <> ".tag == EXPR_EITHER_LEFT || " <> s <> ".tag == EXPR_EITHER_RIGHT);"
    -- , "var_t " <> s' <> " = *(var_t*)(" <> s <> ".value);"
    , "var_t " <> s' <> ";"
    , stmt $ cCall "copyVar" [addrOf s', cCast "var_t*" (s # "value")]

    , "if (" <> s <> ".tag == EXPR_EITHER_LEFT) {"
    , thenPart
    , "} else if (" <> s <> ".tag == EXPR_EITHER_RIGHT) {"
    , elsePart
    , "}"
    ]

-- TODO: Implement with multiple actual function calls?
genProdMatch :: CName -> GPUExp (ProdMatch a r) -> CName -> CodeGen CCode
genProdMatch s p resultName = do
  r <- getProdMatchLams p
  case r of
    Right x ->
      -- Nullary
      genExp x resultName

    Left (argUniqs0, innerLam) -> do
      -- Not nullary
      let lastArg = last argUniqs0
          argUniqs = init argUniqs0

      let itemNames = map (\i -> pairCar i s <> "/* item #" <> show i <> " */") [0..length argUniqs0-1]

      -- TODO: Should the enivronment be saved and restored?
      -- cg_modifyNames (zip argUniqs itemNames)

      le <- fmap cg_le get
      withLocalEnv (le_modifyNames le (zip argUniqs itemNames))
        $ buildAndCall innerLam (pairCar (length argUniqs0-1) s <> "/* item #" <> show (length argUniqs0-1) <> " */") resultName

pairCar :: Int -> CName -> CCode
pairCar 0 p = "((var_t*)" <> p <> ".value)[0]"
pairCar 1 p = "((var_t*)" <> pairCdr 0 p <> ".value)[0]"
pairCar depth p =
  "((var_t*)(" <> (pairCdr (depth-1) p) <> ").value)[0]"

pairCdr :: Int -> CName -> CCode
pairCdr 0 p = "((var_t*)" <> p <> ".value)[1]"
pairCdr depth p =
  "((var_t*)" <> (pairCdr (depth-1) p) <> ".value)[1]"

-- | Get argument uniques for each lambda and also the innermost lambda
getProdMatchLams :: GPUExp (ProdMatch a r) -> CodeGen (Either ([Int], SomeLambda) (GPUExp r))
getProdMatchLams (CastExp x) = getProdMatchLams x
getProdMatchLams (OneProdMatch (Lam (Name n) _)) = do
  lam <- lookupLambda n
  return $ Left ([n], lam)

getProdMatchLams (ProdMatchExp (Lam (Name n) x)) = do
  r <- getProdMatchLams x
  case r of
    Left (restNs, lam) -> return $ Left (n:restNs, lam)
    Right _ -> error "getProdMatchLams"

getProdMatchLams (NullaryMatch x) = return $ Right x

lambdaCName_byInt :: Int -> CName
lambdaCName_byInt i = "lam_" <> show i

lambdaCName :: SomeLambda -> CName
lambdaCName (SomeLambda cl) = lambdaCName_byInt (getNameIdent (lambda_name cl))

genLambda :: SomeLambda -> CodeGen CCode
genLambda sc@(SomeLambda c) = do
  rName <- freshCName

  currEnv <- fmap cg_le get

  let modifyFvEnv =
            le_modifyName
                (le_modifyNames
                  currEnv
                  (zipWith
                    (\(SomeName fv) i -> (getNameUniq fv, fvEnvItem i))
                    (lambda_fvs c)
                    [0..]))

                    -- (zip (map (\(SomeName n) -> getNameUniq n) (lambda_fvs c)) -- TODO: Does this put things in the correct order?
                    --    fvIxes))

  let localEnv
        | lambda_isTailRec c =
            modifyFvEnv
                (getNameUniq (lambda_name c))
                rName
        | otherwise =
            modifyFvEnv
                (getNameUniq (lambda_name c))
                "arg"

  body <- withLocalEnv localEnv (genExp (lambda_body c) rName)

  tempName <- freshCName

  let body'
        | lambda_isTailRec c =
            unlines
              [ rName <> ".tag = EXPR_STEP;"
              , rName <> ".semantic_tag = NO_SEMANTIC_TAG;"
              , rName <> ".value = malloc(sizeof(var_t));"
              -- , "*(var_t*)(" <> rName <> ".value) = arg;"
              , stmt $ cCall "copyVar" [cCast "var_t*" (rName # "value"), addrOf "arg"]
              , "while (" <> rName <> ".tag != EXPR_DONE) {"
              , body
              , "}"
              , ""
              , "var_t " <> tempName <> ";"
              , stmt $ cCall "copyVar"
                          [addrOf tempName, cCast "var_t*" (rName # "value")]
              -- , "var_t " <> tempName <> " = *(var_t*)(" <> rName <> ".value);"
              , rName <> ".tag = " <> tempName <> ".tag;"
              , rName <> ".semantic_tag = " <> tempName <> ".semantic_tag;"
              , stmt $ cCall "copyVar" [cCast "var_t*" (rName # "value"), cCast "var_t*" (tempName # "value")]
              -- , rName <> ".value = " <> tempName <> ".value;"
              ]
        | otherwise = body

  return $
    unlines
      [ "var_t " <> lambdaCName sc <> "(var_t arg, struct closure_t* self) {"
      , "  var_t " <> rName <> ";"
      , body'
      , "  return " <> rName <> ";"
      , "}"
      ]
  where
    fvEnvItem i = "self->fv_env[" <> show i <> "]"

    Name n = lambda_name c

genLambdas :: GPUExp a -> CodeGen CCode
genLambdas e = do
  let lambdas = collectLambdas e

  unlines <$> mapM genLambda lambdas

buildAndCall :: SomeLambda -> CName -> CName -> CodeGen CCode
buildAndCall sLam argName resultName = do
  closureVarName <- freshCName

  closureCode <- buildClosure sLam closureVarName
  callCode <- callClosure sLam closureVarName argName resultName

  return $ unlines
    [ "closure_t " <> closureVarName <> ";"
    , closureCode
    , callCode
    ]

buildClosure :: HasCallStack => SomeLambda -> CName -> CodeGen CCode
buildClosure sc@(SomeLambda c) closureVarName = do
  currEnv <- fmap cg_le get

  let fvs = lambda_fvs c
  traceM $ "////////// fvs = " ++ show fvs
  init_fvEnv <- forM (zip [0..] fvs) (\(i, n@(SomeName fv)) -> do
                            fvName <- cg_lookup (getNameUniq fv)
                            return (cCall "copyVar" [addrOf ((closureVarName # "fv_env") ! i), addrOf fvName] <> ";  // For FV with id " <> (show (getNameUniq fv) <> " with Haskell type " <> showNameType n)))
                            -- return (closureVarName <> ".fv_env[" <> show i <> "] = " <> fvName <> ";  // For FV with id " <> (show (getNameUniq fv) <> " with Haskell type " <> showNameType n)))

  return $
    unlines
      [ closureVarName <> ".fv_env = malloc(sizeof(var_t)*" <> show fvCount <> ");"
      , closureVarName <> ".env_size = " <> show fvCount <> ";"
      , closureVarName <> ".fn = &" <> lambdaCName sc <> ";"
      , unlines init_fvEnv
      ]
  where
    fvCount = length (lambda_fvs c)

callClosure :: SomeLambda -> CName -> CName -> CName -> CodeGen CCode
callClosure (SomeLambda (Lambda { lambda_name })) closureName argName resultName = do
  r <- freshCName
  -- copiedArg <- freshCName
  return $
    unlines
      [
       -- "var_t " <> copiedArg <> ";"
      -- , stmt $ cCall "copyVar" [addrOf copiedArg, addrOf argName]
        "var_t " <> r <> " = " <> closureName <> ".fn(" <> argName <> ", &" <> closureName <> ");"
      , stmt $ cCall "copyVar" [addrOf resultName, addrOf r]
      ]

showNameType :: SomeName -> String
showNameType (SomeName n) = show (typeRep n)

-- TODO: Determine if the warning this gives is a sign of a problem (it
-- is likely to be, at least, a minor bug in GHC):
--
-- Update: Despite the warning, it seems ok.
numTypeInfo :: forall n a. (HasCallStack, Typeable n) => n -> (CName, CName)
numTypeInfo arg =
 case eqT :: Maybe (n :~: Int) of
   Just _ -> ("int", "EXPR_INT")
   Nothing ->
     case eqT :: Maybe (n :~: Float) of
       Just _ -> ("float", "EXPR_FLOAT")
       Nothing ->
         case eqT :: Maybe (n :~: Double) of
           Just _ -> ("double", "EXPR_DOUBLE")
           Nothing ->
             case eqT :: Maybe (n :~: Integer) of
               Just _ -> trace "Warning: using int to represent Integer" ("int", "EXPR_INT")
               Nothing -> error $ "numTypeInfo: invalid lit type: " ++ show (typeOf arg)

getComplexType_maybe :: forall a. Typeable a => Proxy a -> Maybe (CName, CName)
getComplexType_maybe Proxy =
  case eqT :: Maybe (a :~: Complex Float) of
    Just Refl -> Just ("float", "EXPR_FLOAT")
    Nothing ->
      case eqT :: Maybe (a :~: Complex Double) of
        Just Refl -> Just ("double", "EXPR_DOUBLE")
        Nothing -> Nothing

getComplex_maybe :: Typeable a => a -> Maybe (ShowablePair, (CName, CName))
getComplex_maybe x =
  case cast x :: Maybe (Complex Float) of
    Just (a :+ b) -> Just (ShowablePair a b, ("float", "EXPR_FLOAT"))
    Nothing ->
      case cast x :: Maybe (Complex Double) of
        Just (a :+ b) -> Just (ShowablePair a b, ("double", "EXPR_DOUBLE"))
        Nothing -> Nothing

-- Tests and examples --
cTest :: GPUExp Int
cTest =
  CaseExp (Var (Name 0) :: GPUExp (Either Int Float))
    (SumMatchExp
      (OneProdMatch (Lam (Name 1) (Var (Name 1))))
      (OneSumMatch (OneProdMatch (Lam (Name 2) (Var (Name 0))))))

cTest2 :: GPUExp Int
cTest2 =
  CaseExp (Var (Name 0) :: GPUExp (Int, Float))
    (OneSumMatch
      (ProdMatchExp
        (Lam (Name 1)
          (OneProdMatch
            (Lam (Name 2)
              (Var (Name 1)))))))

cTest3 :: GPUExp Int
cTest3 =
  CaseExp (Var (Name 0) :: GPUExp (Int, Float))
    (OneSumMatch
      (ProdMatchExp
        (Lam (Name 1)
          (OneProdMatch
            (Lam (Name 2)
              (Mul (Var (Name 1)) (Var (Name 1))))))))

cTest4 :: GPUExp Int
cTest4 =
  CaseExp (Var (Name 0) :: GPUExp (Int, Float))
    (OneSumMatch
      (ProdMatchExp
        (Lam (Name 1)
          (OneProdMatch
            (Lam (Name 2)
              (Mul (Var (Name 1)) (Lit 11)))))))

(&) :: GPURep a => GPUExp a -> GPUExp (a -> b) -> GPUExp b
(&) = flip App

-- | isEven 6
cTest5 :: GPUExp Bool
cTest5 = Lit 6 &
  TailRec (Lam (Name 0 :: Name Int)
    (IfThenElse (Equal (Var (Name 0 :: Name Int)) (Lit 0))
      (DoneExp TrueExp)
      (IfThenElse (Equal (Var (Name 0 :: Name Int)) (Lit 1))
        (DoneExp FalseExp)
        (StepExp (Sub (Var (Name 0 :: Name Int)) (Lit 2))))))

-- | factorial 5
cTest6 :: GPUExp Int
cTest6 = --(PairExp (Lit 5) (Lit 1)) &
  (construct ((5,1) :: (Int, Int))) &
    TailRec (Lam (Name 0 :: Name (Int, Int))
      (CaseExp (Var (Name 0 :: Name (Int, Int)))
        (OneSumMatch
          (ProdMatchExp
            (Lam (Name 1 :: Name Int)
              (OneProdMatch
                (Lam (Name 2 :: Name Int)
                  (IfThenElse (Equal (Var (Name 1)) (Lit 0 :: GPUExp Int))
                    (DoneExp (Var (Name 2)))
                    (StepExp (PairExp (Sub (Var (Name 1)) (Lit 1)) (Mul (Var (Name 1)) (Var (Name 2)))))
                    ))))))))


text:
-- This example uses the JuicyPixels package the generate the png.
import Control.Lens
import Data.Bool
import Data.Complex
import Data.Dense
import Data.Word

import Codec.Picture

-- Simple example to compute the manelbrot set in parallel. Compile with
--
-- ghc -O2 -threaded examples/mandel
--
-- (add -fllvm is available) and run with
--
-- examples/mandel +RTS -N4
--
-- replacing 4 with the number of processors to use.

main :: IO ()
main = do
  let plane = complexPlane (V2 2000 2000) ((-2.5) :+ (-2)) (1.5 :+ 2)
      m     = mandel 16 <$> plane
      img   = mkImage (manifest m)

  savePngImage "mandel.png" (ImageY8 img)

complexPlane
  :: V2 Int         -- ^ total size
  -> Complex Double -- ^ lower bound
  -> Complex Double -- ^ upper bound
  -> Delayed V2 (Complex Double)
complexPlane l@(V2 x y) a@(rmin :+ imin) (rmax :+ imax) =
  genDelayed l $
    \(V2 j i) -> a + (rstep * fromIntegral i :+ istep * fromIntegral j)
  where
    rstep = (rmax - rmin) / (fromIntegral x - 1)
    istep = (imax - imin) / (fromIntegral y - 1)

mandel :: Int -> Complex Double -> Word8
mandel n = bool 0 255 . any ((>2) . magnitude) . take n . criticalOrbit

criticalOrbit :: Complex Double -> [Complex Double]
criticalOrbit z0 = iterate (quadratic z0) 0
  where quadratic c z = z*z + c

mkImage :: SArray V2 Word8 -> Image Pixel8
mkImage a = Image x y (a^.vector)
  where V2 x y = extent a

ext: hs

max_stars_repo_name: cchalmers/shaped-vector

max_issues_repo_name: cchalmers/shaped-vector

max_forks_repo_name: cchalmers/shaped-vector


text:
-- ex5_01.hs

import Statistics.Distribution
import Statistics.Distribution.DiscreteUniform

y1, y2 :: DiscreteUniform
y1 = discreteUniform 3
y2 = discreteUniform 3

ss = [(i,j)
     | i <- [1..3], j <- [1..3]
     ]

ps = [(probability y1 i)*(probability y1 j)
     | i <- [1..3], j <- [1..3]
     ]

main = do
  putStrLn $ "The sample space is: " ++ show ss
  putStrLn $ "The corresponding probabilities: " ++ show ps
  putStrLn $ "sum ps = " ++ show (sum ps)

max_stars_repo_name: raydsameshima/Stat

max_issues_repo_name: raydsameshima/Stat

max_forks_repo_name: raydsameshima/Stat


text:
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Geometric
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The Geometric distribution. There are two variants of
-- distribution. First is the probability distribution of the number
-- of Bernoulli trials needed to get one success, supported on the set
-- [1,2..] ('GeometricDistribution'). Sometimes it's referred to as
-- the /shifted/ geometric distribution to distinguish from another
-- one.
--
-- Second variant is probability distribution of the number of
-- failures before first success, defined over the set [0,1..]
-- ('GeometricDistribution0').
module Statistics.Distribution.Geometric
    (
      GeometricDistribution
    , GeometricDistribution0
    -- * Constructors
    , geometric
    , geometric0
    -- ** Accessors
    , gdSuccess
    , gdSuccess0
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Control.Applicative ((<$>))
import Control.Monad (liftM)
import Data.Binary (Binary)
import Data.Binary (put, get)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Numeric.MathFunctions.Constants (m_pos_inf, m_neg_inf)
import qualified Statistics.Distribution as D
import qualified System.Random.MWC.Distributions as MWC

----------------------------------------------------------------
-- Distribution over [1..]

newtype GeometricDistribution = GD {
      gdSuccess :: Double
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON GeometricDistribution
instance ToJSON GeometricDistribution

instance Binary GeometricDistribution where
    get = GD <$> get
    put (GD x) = put x

instance D.Distribution GeometricDistribution where
    cumulative = cumulative

instance D.DiscreteDistr GeometricDistribution where
    probability (GD s) n
      | n < 1     = 0
      | otherwise = s * (1-s) ** (fromIntegral n - 1)
    logProbability (GD s) n
       | n < 1     = m_neg_inf
       | otherwise = log s + log (1-s) * (fromIntegral n - 1)

instance D.Mean GeometricDistribution where
    mean (GD s) = 1 / s

instance D.Variance GeometricDistribution where
    variance (GD s) = (1 - s) / (s * s)

instance D.MaybeMean GeometricDistribution where
    maybeMean = Just . D.mean

instance D.MaybeVariance GeometricDistribution where
    maybeStdDev   = Just . D.stdDev
    maybeVariance = Just . D.variance

instance D.Entropy GeometricDistribution where
  entropy (GD s)
    | s == 0 = m_pos_inf
    | s == 1 = 0
    | otherwise = negate $ (s * log s + (1-s) * log (1-s)) / s

instance D.MaybeEntropy GeometricDistribution where
  maybeEntropy = Just . D.entropy

instance D.DiscreteGen GeometricDistribution where
  genDiscreteVar (GD s) g = MWC.geometric1 s g

instance D.ContGen GeometricDistribution where
  genContVar d g = fromIntegral `liftM` D.genDiscreteVar d g

-- | Create geometric distribution.
geometric :: Double                -- ^ Success rate
          -> GeometricDistribution
geometric x
  | x >= 0 && x <= 1 = GD x
  | otherwise        =
    error $ "Statistics.Distribution.Geometric.geometric: probability must be in [0,1] range. Got " ++ show x

cumulative :: GeometricDistribution -> Double -> Double
cumulative (GD s) x
  | x < 1        = 0
  | isInfinite x = 1
  | isNaN      x = error "Statistics.Distribution.Geometric.cumulative: NaN input"
  | otherwise    = 1 - (1-s) ^ (floor x :: Int)

----------------------------------------------------------------
-- Distribution over [0..]

newtype GeometricDistribution0 = GD0 {
      gdSuccess0 :: Double
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON GeometricDistribution0
instance ToJSON GeometricDistribution0

instance Binary GeometricDistribution0 where
    get = GD0 <$> get
    put (GD0 x) = put x

instance D.Distribution GeometricDistribution0 where
    cumulative (GD0 s) x = cumulative (GD s) (x + 1)

instance D.DiscreteDistr GeometricDistribution0 where
    probability    (GD0 s) n = D.probability    (GD s) (n + 1)
    logProbability (GD0 s) n = D.logProbability (GD s) (n + 1)

instance D.Mean GeometricDistribution0 where
    mean (GD0 s) = 1 / s - 1

instance D.Variance GeometricDistribution0 where
    variance (GD0 s) = D.variance (GD s)

instance D.MaybeMean GeometricDistribution0 where
    maybeMean = Just . D.mean

instance D.MaybeVariance GeometricDistribution0 where
    maybeStdDev   = Just . D.stdDev
    maybeVariance = Just . D.variance

instance D.Entropy GeometricDistribution0 where
  entropy (GD0 s) = D.entropy (GD s)

instance D.MaybeEntropy GeometricDistribution0 where
  maybeEntropy = Just . D.entropy

instance D.DiscreteGen GeometricDistribution0 where
  genDiscreteVar (GD0 s) g = MWC.geometric0 s g

instance D.ContGen GeometricDistribution0 where
  genContVar d g = fromIntegral `liftM` D.genDiscreteVar d g

-- | Create geometric distribution.
geometric0 :: Double                -- ^ Success rate
           -> GeometricDistribution0
geometric0 x
  | x >= 0 && x <= 1 = GD0 x
  | otherwise        =
    error $ "Statistics.Distribution.Geometric.geometric: probability must be in [0,1] range. Got " ++ show x

max_stars_repo_name: StefanHubner/statistics

max_issues_repo_name: StefanHubner/statistics

max_forks_repo_name: StefanHubner/statistics


text:
module Parser (SchemeData, readExpr) where

import Text.Parsec
import Text.Parsec.String

import Numeric
import Data.Ratio
import Data.Complex

-- Scheme definition

-- Scheme Data

data SchemeData = Symbol String
          | Bool Bool
          | Character Char
          | String String
          | Number Integer
          | Float Double
          | Ratio Rational
          | Complex (Complex Double)
          | List [SchemeData]
          | DottedList [SchemeData] SchemeData

-- SchemeValue to String for print
showValue :: SchemeData -> String
showValue (Symbol s) = s
showValue (Bool b) = case b of
    True -> "#t"
    False -> "#f"
showValue (Character c) = ['#', '\\', c]
showValue (String s) = "\"" ++ s ++ "\""
showValue (Number n) = (show n)
showValue (Float f) = (show f)
showValue (Ratio r) = (show r)
showValue (Complex (x :+ y)) = (show x) ++ "+" ++ (show y) ++ "i"
showValue (List l) = "(" ++ unwords (map showValue l) ++ ")"
showValue (DottedList l a) = (showValue (List l)) ++ " . " ++ (showValue a)

instance Show SchemeData where show = showValue

-- Symbol Character
-- not scheme symbol
symbol :: Parser Char
symbol = oneOf "#!$%&|*+-/:<=>?@^_~"

-- Scheme Escaped Character
--- \n, \r, \t, \\, \"
escapedChar :: Parser Char
escapedChar = do
    char '\\'
    x <- oneOf "\"\\nrt"
    return $ case x of
        'n' -> '\n'
        'r' -> '\r'
        't' -> '\t'
        _ -> x

-- Scheme String
-- " String "
parseString :: Parser SchemeData
parseString = do
    char '"'
    x <- many1 (escapedChar <|> noneOf "\"")
    char '"'
    return $ String x

-- Scheme Symbol
-- a-z , A-Z, 0-9, _
parseSymbol :: Parser SchemeData
parseSymbol = do
    head <- letter <|> char '_' <|> symbol
    tail <- many (letter <|> digit <|> char '_')
    return $ Symbol (head:tail)

-- Scheme Bool
-- #t, #f
parseBool :: Parser SchemeData
parseBool = do
    char '#'
    x <- oneOf "tf"
    return $ case x of
        't' -> Bool True
        'f' -> Bool False

-- Scheme Number
-- Bin, "#b-"
parseBin :: Parser Integer
parseBin = do
    try $ string "#b"
    x <- many1 $ oneOf "01"
    return $ bin2dec x

-- Oct, "#o-"
parseOct :: Parser Integer
parseOct = do
    try $ string "#o"
    x <- many1 digit
    return $ fst $ (readOct x) !! 0

-- Hex, "#x-"
parseHex :: Parser Integer
parseHex = do
    try $ string "#x"
    x <- many1 (digit <|> letter)
    return $ fst $ (readHex x) !! 0

-- Dec, "#d-", "0-9"
parseDec :: Parser Integer
parseDec = do
    many $ string "#d"
    x <- many1 digit
    return $ read x

-- Number Bin, Hex, Oct, Dec
parseNumber :: Parser SchemeData
parseNumber = do
    num <- parseBin <|> parseHex <|> parseOct <|> parseDec
    return $ Number num

-- Scheme Character
-- "#\a-z"
parseCharacter :: Parser SchemeData
parseCharacter = do
    string "#\\"
    v <- try (string "newline" <|> string "space") <|> do
        x <- anyChar
        notFollowedBy alphaNum
        return [x]
    return $ Character $ case v of
        "newline" -> '\n'
        "space" -> ' '
        _ -> v !! 0

-- Scheme Float
-- "-.-"
parseFloat :: Parser SchemeData
parseFloat = do
    x <- many1 digit
    char '.'
    y <- many1 digit
    return $ Float $ fst $ (readFloat $ x ++ "." ++ y) !! 0

-- Scheme Rational
-- "-/-"
parseRatio :: Parser SchemeData
parseRatio = do
    x <- many1 digit
    char '/'
    y <- many1 digit
    return $ Ratio $ (read x) % (read y)

-- Scheme Complex
parseComplex :: Parser SchemeData
parseComplex = do
    x <- try parseFloat <|> parseNumber
    char '+'
    y <- try parseFloat <|> parseNumber
    char 'i'
    return $ Complex $ (toDouble x) :+ (toDouble y)

-- Parser Combinator

parsecNum :: Parser SchemeData
parsecNum = (try parseComplex) <|> (try parseFloat) <|> (try parseRatio) <|> parseNumber

parsecSym :: Parser SchemeData
parsecSym = (try parseBool) <|> (try parseCharacter) <|> parseSymbol

-- Scheme Expr

parseExpr :: Parser SchemeData
parseExpr = parseString
        <|> try parseQuotes
        <|> try parsecNum
        <|> try parsecSym
        <|> try parseQuoted
        <|> try parseDottedList
        <|> try parseList

readExpr :: String -> SchemeData
readExpr input = case (parse parseExpr "" input) of
     Left x -> String $ "Error message is " ++ (show x)
     Right y -> y

parseList :: Parser SchemeData
parseList = do
    char '('
    x <- sepBy parseExpr spaces
    char ')'
    return $ List x

parseDottedList :: Parser SchemeData
parseDottedList = do
    char '('
    head <- endBy parseExpr spaces
    tail <- do
        char '.'
        spaces
        parseExpr
    char ')'
    return $ DottedList head tail

parseQuoted :: Parser SchemeData
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [(Symbol "quote"), x]

parseUnQuoted :: Parser SchemeData
parseUnQuoted = do
    char ','
    x <- parseExpr
    return $ List [(Symbol "unquote"), x]

parseBackQuoted :: Parser SchemeData
parseBackQuoted = do
    char '`'
    x <- parseExpr
    return $ List [(Symbol "quasiquoted"), x]

parseQuotes :: Parser SchemeData
parseQuotes = parseQuoted <|> parseUnQuoted <|> parseBackQuoted

-- Util function

bin2dec :: String -> Integer
bin2dec [] = 0
bin2dec t@(x:xs) = (read [x]) * 2^(len -1) + (bin2dec xs)
    where len = length t

toDouble :: SchemeData -> Double
toDouble (Number x) = fromIntegral x
toDouble (Float x) = x


text:
module Lib
    ( someFunc
    ) where

{--import Graphics.Gnuplot.Advanced
import Graphics.Gnuplot.MultiPlot
import Graphics.Gnuplot.Terminal.X11
import Graphics.Gnuplot.Graph.TwoDimensional--}
import Numeric.LinearAlgebra
import Graphics.Plot

f :: (Floating a) => a -> a
f x = sin x

someFunc :: IO ()
someFunc = do
  let x = linspace 1000 (-pi,pi)
  mplot [f x]

max_stars_repo_name: shouhei/gnuplot-sample-hs

max_issues_repo_name: shouhei/gnuplot-sample-hs

max_forks_repo_name: shouhei/gnuplot-sample-hs


text:
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
--------------------------------------------------------------------
-- |
-- Copyright :  (c) 2014 Edward Kmett
-- License   :  BSD2
-- Maintainer:  Edward Kmett <ekmett@gmail.com>
-- Stability :  experimental
-- Portability: non-portable
--
-- OpenGL STD140 and STD430 support
--
-- Note STD430 can only be used for shader storage blocks, NOT
-- uniform blocks!
--------------------------------------------------------------------
module Quine.GL.Block
  ( Offset(..)
  , Block(..)
  , GBlock(..)
  , STD140(..)
  , STD430(..)
  ) where

import Control.Applicative
import Control.Category
import Control.Lens hiding (to, from)
import Control.Monad.IO.Class
import Data.Complex
import Data.Data
import Data.Foldable
import Data.Functor.Rep hiding (Rep)
import Data.Int
import Data.Traversable
import Data.Word
import Foreign.Storable
import Foreign.Ptr
import GHC.Generics
import Linear
import Linear.V
import Prelude hiding (id,(.),sequence)
import Quine.GL.Types

newtype Offset (a :: *) (b :: *) = Offset Int
  deriving (Data,Typeable,Generic,Eq,Ord,Show,Read)

instance Category Offset where
  id = Offset 0
  Offset a . Offset b = Offset (a + b)

newtype STD140 a = STD140 { getSTD140 :: a }
  deriving (Data,Typeable,Generic,Functor,Foldable,Traversable,Eq,Ord,Show,Read)

instance Block a => Storable (STD140 a) where
  alignment _ = alignment140 (Proxy :: Proxy a)
  sizeOf _ = sizeOf140 (Proxy :: Proxy a)
  peekByteOff p o = STD140 <$> read140 p (Offset o)
  pokeByteOff p o = write140 p (Offset o) . getSTD140

newtype STD430 a = STD430 { getSTD430 :: a }
  deriving (Data,Typeable,Generic,Functor,Foldable,Traversable,Eq,Ord,Show,Read)

instance Block a => Storable (STD430 a) where
  alignment _ = alignment430 (Proxy :: Proxy a)
  sizeOf _ = sizeOf430 (Proxy :: Proxy a)
  peekByteOff p o = STD430 <$> read430 p (Offset o)
  pokeByteOff p o = write430 p (Offset o) . getSTD430

-- | This describes how to load and store primitives
-- through a uniform/shader storage blocks according to
-- OpenGL STD140 and STD430.
--
-- There are lots of fiddly little constants around, beware.
class Block b where
  -- | As per 'Storable' 'alignment', but matching OpenGL STD140.
  alignment140 :: p b -> Int
  default alignment140 :: (Generic b, GBlock (Rep b)) => p b -> Int
  alignment140 _ = galignment140 (Proxy :: Proxy (Rep b))

  -- | As per 'Storable' 'sizeOf', but matching OpenGL STD140.
  sizeOf140 :: p b -> Int
  default sizeOf140 :: (Generic b, GBlock (Rep b)) => p b -> Int
  sizeOf140 _ = gsizeOf140 (Proxy :: Proxy (Rep b))

  -- | Structures get smashed up to a minimum of a vec4 alignment in 140 mode
  isStruct :: p b -> Bool
  isStruct _ = True

  read140 :: MonadIO m => Ptr a -> Offset a b -> m b
  default read140 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> m b
  read140 p (Offset o) = liftIO $ to <$> gread140 p o

  write140 :: MonadIO m => Ptr a -> Offset a b -> b -> m ()
  default write140 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> b -> m ()
  write140 p (Offset o) b = liftIO $ gwrite140 p o (from b)

  -- | As per 'Storable' 'alignment', but matching OpenGL STD430.
  alignment430 :: p b -> Int
  default alignment430 :: (Generic b, GBlock (Rep b)) => p b -> Int
  alignment430 _ = galignment430 (Proxy :: Proxy (Rep b))

  -- | As per 'Storable' 'sizeOf', but matching OpenGL STD430.
  sizeOf430 :: p b -> Int
  default sizeOf430 :: (Generic b, GBlock (Rep b)) => p b -> Int
  sizeOf430 _ = gsizeOf430 (Proxy :: Proxy (Rep b))

  read430 :: MonadIO m => Ptr a -> Offset a b -> m b
  default read430 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> m b
  read430 p (Offset o) = liftIO $ to <$> gread430 p o

  write430 :: MonadIO m => Ptr a -> Offset a b -> b -> m ()
  default write430 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> b -> m ()
  write430 p (Offset o) b = liftIO $ gwrite430 p o (from b)

-- | Automatically derive STD140 and STD430 alignment using GHC Generics
class GBlock f where
  galignment140 :: p f -> Int
  galignment430 :: p f -> Int
  gsizeOf140    :: p f -> Int
  gsizeOf430    :: p f -> Int
  gread140  :: Ptr a -> Int -> IO (f b)
  gread430  :: Ptr a -> Int -> IO (f b)
  gwrite140 :: Ptr a -> Int -> f b -> IO ()
  gwrite430 :: Ptr a -> Int -> f b -> IO ()

instance GBlock U1 where
  galignment140 _ = 1
  gsizeOf140    _ = 0
  galignment430 _ = 1
  gsizeOf430    _ = 0
  gread140 _ _ = return U1
  gread430 _ _ = return U1
  gwrite140 _ _ U1 = return ()
  gwrite430 _ _ U1 = return ()

instance (GBlock f, GBlock g) => GBlock (f :*: g) where
  galignment140 _ = galignment140 (Proxy :: Proxy f)
              `max` galignment140 (Proxy :: Proxy g)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
              `max` galignment430 (Proxy :: Proxy g)
  gsizeOf140 _ = roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g)) + gsizeOf140 (Proxy :: Proxy g)
  gsizeOf430 _ = roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g)) + gsizeOf430 (Proxy :: Proxy g)
  gread140 p o = (:*:) <$> gread140 p o <*> gread140 p (o + roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g)))
  gread430 p o = (:*:) <$> gread430 p o <*> gread430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g)))
  gwrite140 p o (a :*: b) = do
    gwrite140 p o a
    gwrite140 p (o + roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g))) b
  gwrite430 p o (a :*: b) = do
    gwrite430 p o a
    gwrite430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g))) b

instance GBlock f => GBlock (M1 S c f) where
  galignment140 _ = galignment140 (Proxy :: Proxy f)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
  gsizeOf140    _ = gsizeOf140 (Proxy :: Proxy f)
  gsizeOf430    _ = gsizeOf430 (Proxy :: Proxy f)
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a

instance GBlock f => GBlock (M1 C c f) where
  galignment140 _ = lcm 16 $ galignment140 (Proxy :: Proxy f) -- std140 rule 9
  galignment430 _ = galignment430 (Proxy :: Proxy f) -- std140 rule 9, relaxed by std430
  gsizeOf140    _ = roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy f)) -- std140 rule 9
  gsizeOf430    _ = roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy f)) -- std140 rule 9, relaxed by std430
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a

instance GBlock f => GBlock (M1 D c f) where
  galignment140 _ = galignment140 (Proxy :: Proxy f)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
  gsizeOf140    _ = gsizeOf140 (Proxy :: Proxy f)
  gsizeOf430    _ = gsizeOf430 (Proxy :: Proxy f)
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a

instance Block c => GBlock (K1 i c) where
  galignment140 _ = alignment140 (Proxy :: Proxy c)
  galignment430 _ = alignment430 (Proxy :: Proxy c)
  gsizeOf140    _ = sizeOf140 (Proxy :: Proxy c)
  gsizeOf430    _ = sizeOf430 (Proxy :: Proxy c)
  gread140 p o = K1 <$> read140 p (Offset o)
  gread430 p o = K1 <$> read430 p (Offset o)
  gwrite140 p o (K1 a) = write140 p (Offset o) a
  gwrite430 p o (K1 a) = write430 p (Offset o) a

toBool :: Int32 -> Bool
toBool 0 = False
toBool _ = True

fromBool :: Bool -> Int32
fromBool False = 0
fromBool True = 1

instance Block Bool where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fromBool b)
  read430 = read140
  write430 = write140

instance Block Float where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Double where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Int32 where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Word32 where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block BVec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ fmap toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fmap fromBool b)
  read430 = read140
  write430 = write140

instance Block BVec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ fmap toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fmap fromBool b)
  read430 = read140
  write430 = write140

instance Block BVec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ fmap toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fmap fromBool b)
  read430 = read140
  write430 = write140

instance Block Vec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Vec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Vec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block DVec2 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block DVec3 where
  alignment140 _ = 32
  sizeOf140 _    = 24
  alignment430 _ = 32
  sizeOf430 _    = 24
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block DVec4 where
  alignment140 _ = 32
  sizeOf140 _    = 32
  alignment430 _ = 32
  sizeOf430 _    = 32
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block IVec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block IVec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block IVec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block UVec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block UVec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block UVec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Mat2 where
  alignment140 _ = 16 -- per vec4, despite being vec2
  sizeOf140    _ = 32 -- 2 columns, each rounded up to vec4 size
  alignment430 _ = 8  -- vec2
  sizeOf430    _ = 16 -- 2 columns, each vec2 in size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a c <- peekByteOff p o
    V2 b d <- peekByteOff p (o + 16)
    return $ V2 (V2 a b) (V2 c d)
  write140 p (Offset o)
    (V2 (V2 a b)
        (V2 c d)) = liftIO $ do
    pokeByteOff p o        (V2 a b)
    pokeByteOff p (o + 16) (V2 c d)
  read430 p (Offset o) = liftIO $ do
    V2 a c <- peekByteOff p o
    V2 b d <- peekByteOff p (o + 8)
    return $ V2 (V2 a b) (V2 c d)
  write430 p (Offset o)
    (V2 (V2 a b)
        (V2 c d)) = liftIO $ do
    pokeByteOff p o       (V2 a b)
    pokeByteOff p (o + 8) (V2 c d)

instance Block DMat2 where
  alignment140 _ = 16 -- dvec2 = vec4 in size
  sizeOf140    _ = 32 -- 2 columns, perfect fit!
  alignment430 _ = 16 -- dvec2 = vec4 in size
  sizeOf430    _ = 32 -- 2 columns, perfect fit!
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a c <- peekByteOff p o
    V2 b d <- peekByteOff p (o + 16)
    return $ V2 (V2 a b) (V2 c d)
  write140 p (Offset o)
    (V2 (V2 a b)
        (V2 c d)) = liftIO $ do
    pokeByteOff p o        (V2 a b)
    pokeByteOff p (o + 16) (V2 c d)
  read430 = read140
  write430 = write140

instance Block Mat3x2 where
  alignment140 _ = 16 -- per vec4, despite being vec3s
  sizeOf140    _ = 32 -- 2 columns, each rounded up to vec4 size
  alignment430 _ = 16 -- per vec4, despite being vec3s
  sizeOf430    _ = 32 -- 2 columns, each rounded up to vec4 size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a c e <- peekByteOff p o
    V3 b d f <- peekByteOff p (o + 16)
    return $ V3 (V2 a b) (V2 c d) (V2 e f)
  write140 p (Offset o)
    (V3 (V2 a b)
        (V2 c d)
        (V2 e f)) = liftIO $ do
    pokeByteOff p o        (V3 a b e)
    pokeByteOff p (o + 16) (V3 c d f)
  read430 = read140
  write430 = write140

instance Block DMat3x2 where
  alignment140 _ = 32 -- dvec3s = 24, rounded up to 2*vec4 in size
  sizeOf140    _ = 64 -- 2 columns, each rounded up to 2*vec4 size
  alignment430 _ = 32 -- dvec3s = 24, rounded up to 2*vec4 in size
  sizeOf430    _ = 64 -- 2 columns, each rounded up to 2*vec4 size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a c e <- peekByteOff p o
    V3 b d f <- peekByteOff p (o + 32)
    return $ V3 (V2 a b) (V2 c d) (V2 e f)
  write140 p (Offset o)
    (V3 (V2 a b)
        (V2 c d)
        (V2 e f)) = liftIO $ do
    pokeByteOff p o        (V3 a b e)
    pokeByteOff p (o + 32) (V3 c d f)
  read430 = read140
  write430 = write140

instance Block Mat4x2 where
  alignment140 _ = 16 -- per vec4
  sizeOf140    _ = 32 -- 2 columns
  alignment430 _ = 16 -- per vec4
  sizeOf430    _ = 32 -- 2 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a c e g <- peekByteOff p o
    V4 b d f h <- peekByteOff p (o + 16)
    return $ V4 (V2 a b) (V2 c d) (V2 e f) (V2 g h)
  write140 p (Offset o)
    (V4 (V2 a b)
        (V2 c d)
        (V2 e f)
        (V2 g h)) = liftIO $ do
    pokeByteOff p o        (V4 a b e g)
    pokeByteOff p (o + 16) (V4 c d f h)
  read430 = read140
  write430 = write140

instance Block DMat4x2 where
  alignment140 _ = 32 -- per dvec4 = 2*vec4
  sizeOf140    _ = 64 -- 2 columns
  alignment430 _ = 32 -- per dvec4 = 2*vec4
  sizeOf430    _ = 64 -- 2 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a c e g <- peekByteOff p o
    V4 b d f h <- peekByteOff p (o + 32)
    return $ V4 (V2 a b) (V2 c d) (V2 e f) (V2 g h)
  write140 p (Offset o)
    (V4 (V2 a b)
        (V2 c d)
        (V2 e f)
        (V2 g h)) = liftIO $ do
    pokeByteOff p o        (V4 a b e g)
    pokeByteOff p (o + 32) (V4 c d f h)
  read430 = read140
  write430 = write140

instance Block Mat2x3 where
  alignment140 _ = 16 -- per vec4, despite being vec2 by array rules
  sizeOf140    _ = 48 -- 3 columns, each a vec4 in size, despite being vec2s
  alignment430 _ = 8  -- per vec2
  sizeOf430    _ = 24 -- 3 columns, each a vec2 in size
  isStruct  _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a d <- peekByteOff p o
    V2 b e <- peekByteOff p (o + 16)
    V2 c f <- peekByteOff p (o + 32)
    return $ V2 (V3 a b c)
                (V3 d e f)
  write140 p (Offset o)
    (V2 (V3 a b c)
        (V3 d e f)) = liftIO $ do
    pokeByteOff p o        (V2 a d)
    pokeByteOff p (o + 16) (V2 b e)
    pokeByteOff p (o + 32) (V2 c f)
  read430 p (Offset o) = liftIO $ do
    V2 a d <- peekByteOff p o
    V2 b e <- peekByteOff p (o + 8)
    V2 c f <- peekByteOff p (o + 16)
    return $ V2 (V3 a b c)
                (V3 d e f)
  write430 p (Offset o)
    (V2 (V3 a b c)
        (V3 d e f)) = liftIO $ do
    pokeByteOff p o        (V2 a d)
    pokeByteOff p (o + 8)  (V2 b e)
    pokeByteOff p (o + 16) (V2 c f)

instance Block DMat2x3 where
  alignment140 _ = 16 -- a dvec2 is one vec4 in size
  sizeOf140    _ = 48 -- 3 columns, each a vec4 in size
  alignment430 _ = 16 -- a dvec2 is one vec4 in size
  sizeOf430    _ = 48 -- 3 columns, each a vec4 in size
  isStruct     _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a d <- peekByteOff p o
    V2 b e <- peekByteOff p (o + 16)
    V2 c f <- peekByteOff p (o + 32)
    return $ V2 (V3 a b c)
                (V3 d e f)
  write140 p (Offset o)
    (V2 (V3 a b c)
        (V3 d e f)) = liftIO $ do
    pokeByteOff p o        (V2 a d)
    pokeByteOff p (o + 16) (V2 b e)
    pokeByteOff p (o + 32) (V2 c f)
  read430 = read140
  write430 = write140

instance Block Mat3 where
  alignment140 _ = 16 -- per vec4, despite being vec3
  sizeOf140    _ = 48 -- 3 columns, each rounded up to vec4 size
  alignment430 _ = 16 -- a dvec2 is one vec4 in size
  sizeOf430    _ = 48 -- 3 columns, each a vec4 in size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a d g <- peekByteOff p o
    V3 b e h <- peekByteOff p (o + 16)
    V3 c f i <- peekByteOff p (o + 24)
    return $ V3 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
  write140 p (Offset o)
    (V3 (V3 a b c)
        (V3 d e f)
        (V3 g h i)) = liftIO $ do
    pokeByteOff p o        (V3 a d g)
    pokeByteOff p (o + 16) (V3 b e h)
    pokeByteOff p (o + 32) (V3 c f i)
  read430 = read140
  write430 = write140

instance Block DMat3 where
  alignment140 _ = 32 -- dvec3 = 1.5vec4, round up to 2*vec2
  sizeOf140    _ = 96 -- 3 columns, each rounded up to 2*vec4 size
  alignment430 _ = 32 -- a dvec2 is one vec4 in size
  sizeOf430    _ = 96 -- 3 columns, each a vec4 in size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a d g <- peekByteOff p o
    V3 b e h <- peekByteOff p (o + 32)
    V3 c f i <- peekByteOff p (o + 64)
    return $ V3 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
  write140 p (Offset o)
    (V3 (V3 a b c)
        (V3 d e f)
        (V3 g h i)) = liftIO $ do
    pokeByteOff p o        (V3 a d g)
    pokeByteOff p (o + 32) (V3 b e h)
    pokeByteOff p (o + 64) (V3 c f i)
  read430 = read140
  write430 = write140

instance Block Mat4x3 where
  alignment140 _ = 16 -- per vec4
  sizeOf140    _ = 48 -- 3 columns
  alignment430 _ = 16 -- per vec4
  sizeOf430    _ = 48 -- 3 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a d g j <- peekByteOff p o
    V4 b e h k <- peekByteOff p (o + 16)
    V4 c f i l <- peekByteOff p (o + 32)
    return $ V4 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
                (V3 j k l)
  write140 p (Offset o)
    (V4 (V3 a b c)
        (V3 d e f)
        (V3 g h i)
        (V3 j k l)) = liftIO $ do
    pokeByteOff p o        (V4 a d g j)
    pokeByteOff p (o + 16) (V4 b e h k)
    pokeByteOff p (o + 32) (V4 c f i l)
  read430 = read140
  write430 = write140

instance Block DMat4x3 where
  alignment140 _ = 32 -- dvec4 is 2*vec4 in size
  sizeOf140    _ = 48 -- 3 columns
  alignment430 _ = 32 -- dvec4 is 2*vec4 in size
  sizeOf430    _ = 48 -- 3 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a d g j <- peekByteOff p o
    V4 b e h k <- peekByteOff p (o + 32)
    V4 c f i l <- peekByteOff p (o + 64)
    return $ V4 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
                (V3 j k l)
  write140 p (Offset o)
    (V4 (V3 a b c)
        (V3 d e f)
        (V3 g h i)
        (V3 j k l)) = liftIO $ do
    pokeByteOff p o        (V4 a d g j)
    pokeByteOff p (o + 32) (V4 b e h k)
    pokeByteOff p (o + 64) (V4 c f i l)
  read430 = read140
  write430 = write140

instance Block Mat2x4 where
  alignment140 _ = 16 -- 2 rows, but vec2 rounds up to vec4 as per array
  sizeOf140    _ = 64 -- 4 columns, each rounded up to 16 bytes each
  alignment430 _ = 8  -- 2 rows, each a vec2 in size
  sizeOf430    _ = 32 -- 4 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a e <- peekByteOff p o
    V2 b f <- peekByteOff p (o + 16)
    V2 c g <- peekByteOff p (o + 32)
    V2 d h <- peekByteOff p (o + 48)
    return $ V2 (V4 a b c d)
                (V4 e f g h)
  write140 p (Offset o)
    (V2 (V4 a b c d)
        (V4 e f g h)) = liftIO $ do
    pokeByteOff p o        (V2 a e)
    pokeByteOff p (o + 16) (V2 b f)
    pokeByteOff p (o + 32) (V2 c g)
    pokeByteOff p (o + 48) (V2 d h)
  read430 p (Offset o) = liftIO $ do
    V2 a e <- peekByteOff p o
    V2 b f <- peekByteOff p (o + 8)
    V2 c g <- peekByteOff p (o + 16)
    V2 d h <- peekByteOff p (o + 24)
    return $ V2 (V4 a b c d)
                (V4 e f g h)
  write430 p (Offset o)
    (V2 (V4 a b c d)
        (V4 e f g h)) = liftIO $ do
    pokeByteOff p o        (V2 a e)
    pokeByteOff p (o + 8) (V2 b f)
    pokeByteOff p (o + 16) (V2 c g)
    pokeByteOff p (o + 24) (V2 d h)

instance Block DMat2x4 where
  alignment140 _ = 16 -- 2 rows, and dvec2 = vec4 in size
  sizeOf140    _ = 64 -- 4 columns, perfect fit
  alignment430 _ = 16 -- 2 rows, and dvec2 = vec4 in size
  sizeOf430    _ = 64 -- 4 columns, perfect fit
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a e <- peekByteOff p o
    V2 b f <- peekByteOff p (o + 16)
    V2 c g <- peekByteOff p (o + 32)
    V2 d h <- peekByteOff p (o + 48)
    return $ V2 (V4 a b c d)
                (V4 e f g h)
  write140 p (Offset o)
    (V2 (V4 a b c d)
        (V4 e f g h)) = liftIO $ do
    pokeByteOff p o        (V2 a e)
    pokeByteOff p (o + 16) (V2 b f)
    pokeByteOff p (o + 32) (V2 c g)
    pokeByteOff p (o + 48) (V2 d h)
  read430 = read140
  write430 = write140

instance Block Mat3x4 where
  alignment140 _ = 16 -- 3 rows, but vec3 rounds up to vec4
  sizeOf140    _ = 64 -- 4 columns, each rounded up to 16 bytes each
  alignment430 _ = 16 -- 3 rows, but vec3 rounds up to vec4
  sizeOf430    _ = 64 -- 4 columns, each rounded up to 16 bytes each
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a e i <- peekByteOff p o
    V3 b f j <- peekByteOff p (o + 16)
    V3 c g k <- peekByteOff p (o + 32)
    V3 d h l <- peekByteOff p (o + 48)
    return $ V3 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
  write140 p (Offset o)
    (V3 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)) = liftIO $ do
    pokeByteOff p o        (V3 a e i)
    pokeByteOff p (o + 16) (V3 b f j)
    pokeByteOff p (o + 32) (V3 c g k)
    pokeByteOff p (o + 48) (V3 d h l)
  read430 = read140
  write430 = write140

instance Block DMat3x4 where
  alignment140 _ = 32  -- 3 rows, but dvec3 rounds up to 2*vec4
  sizeOf140    _ = 128 -- 4 columns, each rounded up to 32 bytes each
  alignment430 _ = 32  -- 3 rows, but dvec3 rounds up to 2*vec4
  sizeOf430    _ = 128 -- 4 columns, each rounded up to 32 bytes each
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a e i <- peekByteOff p o
    V3 b f j <- peekByteOff p (o + 32)
    V3 c g k <- peekByteOff p (o + 64)
    V3 d h l <- peekByteOff p (o + 96)
    return $ V3 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
  write140 p (Offset o)
    (V3 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)) = liftIO $ do
    pokeByteOff p o        (V3 a e i)
    pokeByteOff p (o + 32) (V3 b f j)
    pokeByteOff p (o + 64) (V3 c g k)
    pokeByteOff p (o + 96) (V3 d h l)
  read430 = read140
  write430 = write140

instance Block Mat4 where
  alignment140 _ = 16
  sizeOf140    _ = 64
  alignment430 _ = 16
  sizeOf430    _ = 64
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a e i m <- peekByteOff p o
    V4 b f j n <- peekByteOff p (o + 16)
    V4 c g k q <- peekByteOff p (o + 32)
    V4 d h l r <- peekByteOff p (o + 48)
    return $ V4 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
                (V4 m n q r)
  write140 p (Offset o)
    (V4 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)
        (V4 m n q r)) = liftIO $ do
    pokeByteOff p o        (V4 a e i m)
    pokeByteOff p (o + 16) (V4 b f j n)
    pokeByteOff p (o + 32) (V4 c g k q)
    pokeByteOff p (o + 48) (V4 d h l r)
  read430 = read140
  write430 = write140

instance Block DMat4 where
  alignment140 _ = 32
  sizeOf140    _ = 128
  alignment430 _ = 32
  sizeOf430    _ = 128
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a e i m <- peekByteOff p o
    V4 b f j n <- peekByteOff p (o + 32)
    V4 c g k q <- peekByteOff p (o + 64)
    V4 d h l r <- peekByteOff p (o + 96)
    return $ V4 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
                (V4 m n q r)
  write140 p (Offset o)
    (V4 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)
        (V4 m n q r)) = liftIO $ do
    pokeByteOff p o        (V4 a e i m)
    pokeByteOff p (o + 32) (V4 b f j n)
    pokeByteOff p (o + 64) (V4 c g k q)
    pokeByteOff p (o + 96) (V4 d h l r)
  read430 = read140
  write430 = write140

instance Block (Complex Float) where
  alignment140 _ = 16
  sizeOf140    _ = 16
  alignment430 _ = 8
  sizeOf430    _ = 8
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V2 a b <- peekByteOff p o
    return $ a :+ b
  write140 p (Offset o) (a :+ b) = liftIO $ pokeByteOff p o (V2 a b)
  read430  = read140
  write430 = write140

instance Block (Complex Double) where
  alignment140 _ = 16
  sizeOf140    _ = 16
  alignment430   = alignment140
  sizeOf430      = sizeOf140
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V2 a b <- peekByteOff p o
    return $ a :+ b
  write140 p (Offset o) (a :+ b) = liftIO $ pokeByteOff p o (V2 a b)
  read430  = read140
  write430 = write140

-- | encoded to match @shaders/math/quaternion.h@
instance Block (Quaternion Float) where
  alignment140 _ = 16
  sizeOf140    _ = 16
  alignment430   = alignment140
  sizeOf430      = sizeOf140
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V4 a b c d <- peekByteOff p o
    return $ Quaternion d (V3 a b c)
  write140 p (Offset o) (Quaternion d (V3 a b c)) = liftIO $ pokeByteOff p o (V4 a b c d)
  read430  = read140
  write430 = write140

instance Block (Quaternion Double) where
  alignment140 _ = 32
  sizeOf140    _ = 32
  alignment430   = alignment140
  sizeOf430      = sizeOf140
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V4 a b c d <- peekByteOff p o
    return $ Quaternion d (V3 a b c)
  write140 p (Offset o) (Quaternion d (V3 a b c)) = liftIO $ pokeByteOff p o (V4 a b c d)
  read430  = read140
  write430 = write140

-- | Can be used for fixed-sized arrays
instance (Dim n, Block a) => Block (V n a) where
  isStruct _ = isStruct (Proxy :: Proxy a)
  alignment140 _
    | isStruct (Proxy :: Proxy a) = lcm 16 n -- std140 rule 9
    | otherwise = n
    where n = alignment140 (Proxy :: Proxy a)
  alignment430 _ = alignment430 (Proxy :: Proxy a)
  sizeOf140 _ = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a)) * fromIntegral (reflectDim (Proxy :: Proxy n))
  sizeOf430 _ = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a)) * fromIntegral (reflectDim (Proxy :: Proxy n))
  read140 p (Offset o) = liftIO $ sequence $ tabulate $ \i -> read140 p $ Offset (o + i*d) where
    d = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a))
  write140 p (Offset o) v = liftIO $ iforM_ v $ \i -> write140 p (Offset (o + i*d)) where
    d = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a))
  read430 p (Offset o) = liftIO $ sequence $ tabulate $ \i -> read430 p $ Offset (o + i*d) where
    d = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a))
  write430 p (Offset o) v = liftIO $ iforM_ v $ \i -> write430 p (Offset (o + i*d)) where
    d = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a))

-- | @roundUp k n@ rounds up k up to an integral multiple of n
roundUp :: Int -> Int -> Int
roundUp k n = k + mod (n - k) n

instance (Block a, Block b) => Block (a,b)
instance (Block a, Block b, Block c) => Block (a,b,c)

max_stars_repo_name: MaxDaten/quine

max_issues_repo_name: MaxDaten/quine

max_forks_repo_name: MaxDaten/quine