{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
-- This file takes 30+ seconds to compile with pattern match warnings
-- in GHC 8.4. https://gitlab.haskell.org/ghc/ghc/-/issues/14987
{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-inaccessible-code #-}

--
-- Copyright (c) 2019, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

-- | Translate from the typed to an untyped functional representation
module Feldspar.Core.Middleend.FromTyped
  ( toU
  ) where

import qualified Feldspar.Core.UntypedRepresentation as U
import qualified Feldspar.Core.NestedTuples as T
import Feldspar.Core.Types (TypeRep(..), TypeF(..), (:>)(..))
import qualified Feldspar.Core.Types as T
import Feldspar.Core.UntypedRepresentation hiding (Type(..), ScalarType(..))
import Feldspar.Core.ValueInfo (ValueInfo(..), ValueKind(..))
import Feldspar.Range (Range(..))
import qualified Feldspar.Core.Representation as R
import Feldspar.Core.Representation (AExpr(..), Expr(..))
import Data.Complex (Complex(..))
import Feldspar.Lattice (Lattice, universal)

toU :: AExpr a -> UntypedFeld ValueInfo
toU (((R.Info i) :: R.Info a) :& e)
  | Sym (R.Variable (R.Var n s)) <- e
  = i2 $ Variable $ Var n (untypeType tr i) s
  | Sym (R.Literal v) <- e
  = i2 $ Literal $ literal tr i v
  | Sym op <- e
  = i2 $ App (trOp op) (untypeType tr i) []
  | Sym (R.Lambda (R.Var n s)) :@ e' <- e
  , FunType b _ <- tr
  = i2 $ Lambda (Var n (untypeType b (fst i)) s) $ toU e'
  | Sym R.Cons :@ a1 :@ a2 <- e
  , e' <- toU a1
  , In _ (App Tup (U.TupType ts) es) <- toU a2
  = i2 $ App Tup (U.TupType $ typeof e' : ts) $ e' : es
  | Sym R.Car :@ a <- e
  , In _ (App (Drop n) (U.TupType (t:_)) es) <- addDrop $ toU a
  = i2 $ App (Sel n) t es
  | Sym R.Cdr :@ a <- e
  , In _ (App (Drop n) (U.TupType (_:ts)) es) <- addDrop $ toU a
  = i2 $ App (Drop $ n + 1) (U.TupType ts) es
  | Sym R.Tup :@ a <- e
  , In _ e' <- toU a
  = i2 e'
  | (op, es) <- go e []
  = i2 $ App op (untypeType tr i) es
  where tr = typeRepF :: TypeRep a
        i2 = In $ toValueInfo tr i
        go :: forall a' . Expr a' -> [UntypedFeld ValueInfo] -> (Op, [UntypedFeld ValueInfo])
        go (Sym op) es = (trOp op, es)
        go (f :@ e') es = go f $ toU e' : es
        addDrop e'@(In _ (App (Drop _) _ _)) = e'
        addDrop e' = In (error "FromTyped: temporary drop")
                         (App (Drop 0) (typeof e') [e'])

-- | Translate a Typed operator to the corresponding untyped one
trOp :: R.Op a -> Op
trOp R.GetLength       = GetLength
trOp R.Parallel        = Parallel
trOp R.Append          = Append
trOp R.GetIx           = GetIx
trOp R.SetLength       = SetLength
trOp R.Sequential      = Sequential
trOp R.SetIx           = SetIx
trOp R.Let             = Let
trOp R.Bit             = Bit
trOp R.Complement      = Complement
trOp R.ReverseBits     = ReverseBits
trOp R.BitScan         = BitScan
trOp R.BitCount        = BitCount
trOp R.BAnd            = BAnd
trOp R.BOr             = BOr
trOp R.BXor            = BXor
trOp R.SetBit          = SetBit
trOp R.ClearBit        = ClearBit
trOp R.ComplementBit   = ComplementBit
trOp R.TestBit         = TestBit
trOp R.ShiftLU         = ShiftLU
trOp R.ShiftRU         = ShiftRU
trOp R.ShiftL          = ShiftL
trOp R.ShiftR          = ShiftR
trOp R.RotateLU        = RotateLU
trOp R.RotateRU        = RotateRU
trOp R.RotateL         = RotateL
trOp R.RotateR         = RotateR
trOp R.RealPart        = RealPart
trOp R.ImagPart        = ImagPart
trOp R.Conjugate       = Conjugate
trOp R.Magnitude       = Magnitude
trOp R.Phase           = Phase
trOp R.Cis             = Cis
trOp R.MkComplex       = MkComplex
trOp R.MkPolar         = MkPolar
trOp R.Condition       = Condition
trOp R.ConditionM      = ConditionM
trOp R.F2I             = F2I
trOp R.I2N             = I2N
trOp R.B2I             = B2I
trOp R.Round           = Round
trOp R.Ceiling         = Ceiling
trOp R.Floor           = Floor
trOp R.ESkip           = ESkip
trOp R.EMaterialize    = EMaterialize
trOp R.EWrite          = EWrite
trOp R.EPar            = EPar
trOp R.EparFor         = EparFor
trOp R.Equal           = Equal
trOp R.NotEqual        = NotEqual
trOp R.Undefined       = Undefined
trOp (R.Assert s)      = Assert s
trOp (R.ForeignImport s _) = ForeignImport s
trOp R.Exp             = Exp
trOp R.Sqrt            = Sqrt
trOp R.Log             = Log
trOp R.Sin             = Sin
trOp R.Tan             = Tan
trOp R.Cos             = Cos
trOp R.Asin            = Asin
trOp R.Atan            = Atan
trOp R.Acos            = Acos
trOp R.Sinh            = Sinh
trOp R.Tanh            = Tanh
trOp R.Cosh            = Cosh
trOp R.Asinh           = Asinh
trOp R.Atanh           = Atanh
trOp R.Acosh           = Acosh
trOp R.Pow             = Pow
trOp R.LogBase         = LogBase
trOp R.Pi              = Pi
trOp R.DivFrac         = DivFrac
trOp R.MkFuture        = MkFuture
trOp R.Await           = Await
trOp R.Quot            = Quot
trOp R.Rem             = Rem
trOp R.Div             = Div
trOp R.Mod             = Mod
trOp R.IExp            = IExp
trOp R.Not             = Not
trOp R.And             = And
trOp R.Or              = Or
trOp R.ForLoop         = ForLoop
trOp R.WhileLoop       = WhileLoop
trOp R.While           = While
trOp R.For             = For
trOp R.Run             = Run
trOp R.Return          = Return
trOp R.Bind            = Bind
trOp R.Then            = Then
trOp R.When            = When
trOp R.NewArr_         = NewArr_
trOp R.ArrLength       = ArrLength
trOp R.NewArr          = NewArr
trOp R.GetArr          = GetArr
trOp R.SetArr          = SetArr
trOp R.RunMutableArray = RunMutableArray
trOp R.WithArray       = WithArray
trOp R.NewRef          = NewRef
trOp R.GetRef          = GetRef
trOp R.SetRef          = SetRef
trOp R.ModRef          = ModRef
trOp R.Nil             = Tup
trOp R.NoInline        = NoInline
trOp R.Abs             = Abs
trOp R.Sign            = Sign
trOp R.Add             = Add
trOp R.Sub             = Sub
trOp R.Mul             = Mul
trOp R.ParRun          = ParRun
trOp R.ParGet          = ParGet
trOp R.ParFork         = ParFork
trOp R.ParNew          = ParNew
trOp R.ParYield        = ParYield
trOp R.ParPut          = ParPut
trOp R.LTH             = LTH
trOp R.GTH             = GTH
trOp R.LTE             = LTE
trOp R.GTE             = GTE
trOp R.Min             = Min
trOp R.Max             = Max
trOp R.Atan2           = Atan2
trOp R.Save            = Save
trOp (R.PropSize _)    = PropSize
-- trOp R.SourceInfo      = SourceInfo
trOp R.Switch          = Switch
-- trOp R.Call            = Call
trOp (R.Variable _)    = error "trOp: Variable"
trOp (R.Lambda _)      = error "trOp: Lambda"
trOp (R.Literal _)     = error "trOp: Literal"
trOp R.Cons            = error "trOp: Cons"
trOp R.Car             = error "trOp: Car"
trOp R.Cdr             = error "trOp: Cdr"
trOp R.Tup             = error "trOp: Tup"

-- | Convert a BitWidth to an untyped Size
convSize :: T.BitWidth a -> U.Size
convSize T.N8      = U.S8
convSize T.N16     = U.S16
convSize T.N32     = U.S32
convSize T.N64     = U.S64

-- | Default size for numeric types
defaultNumSize :: Lattice (Range a) => TypeRep a -> T.Size a
defaultNumSize IntType{} = universal
defaultNumSize FloatType = universal
defaultNumSize DoubleType = universal
defaultNumSize t = error $ "defaultNumSize: missing numeric type: " ++ show t

untypeType :: TypeRep a -> T.Size a -> U.Type
untypeType UnitType _               = U.TupType []
untypeType BoolType _               = 1 U.:# U.BoolType
untypeType (IntType s n) _          = 1 U.:# U.IntType (convSign s) (convSize n)
untypeType FloatType _              = 1 U.:# U.FloatType
untypeType DoubleType _             = 1 U.:# U.DoubleType
untypeType (ComplexType t) _        = 1 U.:# U.ComplexType
  (case t of
    FloatType -> untypeType t (defaultNumSize t)
    DoubleType -> untypeType t (defaultNumSize t)
    _ -> error $ "untypeType: Missing complex type:" ++ show t)
untypeType (Tup2Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup3Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup4Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup5Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup6Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup7Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup8Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup9Type t) sz          = U.TupType $ untypeTup t sz
untypeType (Tup10Type t) sz         = U.TupType $ untypeTup t sz
untypeType (Tup11Type t) sz         = U.TupType $ untypeTup t sz
untypeType (Tup12Type t) sz         = U.TupType $ untypeTup t sz
untypeType (Tup13Type t) sz         = U.TupType $ untypeTup t sz
untypeType (Tup14Type t) sz         = U.TupType $ untypeTup t sz
untypeType (Tup15Type t) sz         = U.TupType $ untypeTup t sz
untypeType (MutType a) sz              = U.MutType (untypeType a sz)
untypeType (RefType a) sz              = U.RefType (untypeType a sz)
untypeType (ArrayType a) (rs :> es)    = U.ArrayType rs (untypeType a es)
untypeType (MArrType a) (rs :> es)     = U.MArrType rs (untypeType a es)
untypeType (ParType a) sz              = U.ParType (untypeType a sz)
untypeType (ElementsType a) (_ :> es)  = U.ElementsType (untypeType a es)
untypeType c@ConsType{} sz             = U.TupType $ untypeTup c sz
untypeType NilType        _            = U.TupType []
untypeType (IVarType a) sz             = U.IVarType $ untypeType a sz
untypeType (FunType a b) (sa, sz)      = U.FunType (untypeType a sa) (untypeType b sz)
untypeType (FValType a) sz             = U.FValType (untypeType a sz)

untypeTup :: TypeRep (T.Tuple a) -> T.Size (T.Tuple a) -> [U.Type]
untypeTup (ConsType a b) (sa,sb) = untypeType a sa : untypeTup b sb
untypeTup NilType        _       = []

convSign :: T.Signedness a -> U.Signedness
convSign T.U       = Unsigned
convSign T.S       = Signed

literal :: TypeRep a -> T.Size a -> a -> Lit
literal UnitType        _ () = LTup []
literal BoolType        _  a = LBool a
literal (IntType s n)   _  a = LInt (convSign s) (convSize n) (toInteger a)
literal FloatType       _  a = LFloat a
literal DoubleType      _  a = LDouble a
literal (ArrayType t) (_ :> sz) a = LArray t' $ map (literal t sz) a
  where t' = untypeType t sz
literal (ComplexType t) _ (r :+ i)
  = case t of
     FloatType -> LComplex (literal t (defaultNumSize t) r)
                           (literal t (defaultNumSize t) i)
     DoubleType -> LComplex (literal t (defaultNumSize t) r)
                            (literal t (defaultNumSize t) i)
     _ -> error $ "literal: Missing complex type: " ++ show t
literal _ _ _ = error "Missing pattern: FromTyped.hs: literal"

-- | Construct a ValueInfo from a TypeRep and a Size
toValueInfo :: TypeRep a -> T.Size a -> ValueInfo
toValueInfo UnitType          _             = VIProd ProdKind []
-- FIXME: No range for boolean types yet.
toValueInfo BoolType                r       = VIBool    r
toValueInfo (IntType T.U T.N8)      r       = VIWord8   r
toValueInfo (IntType T.S T.N8)      r       = VIInt8    r
toValueInfo (IntType T.U T.N16)     r       = VIWord16  r
toValueInfo (IntType T.S T.N16)     r       = VIInt16   r
toValueInfo (IntType T.U T.N32)     r       = VIWord32  r
toValueInfo (IntType T.S T.N32)     r       = VIInt32   r
toValueInfo (IntType T.U T.N64)     r       = VIWord64  r
toValueInfo (IntType T.S T.N64)     r       = VIInt64   r
-- FIXME: No range for FP types and ComplexType yet.
toValueInfo FloatType         _             = VIFloat
toValueInfo DoubleType        _             = VIDouble
toValueInfo (ComplexType _)   _             = VIProd ProdKind []
toValueInfo (Tup2Type t) sz                 = toValueInfo t sz
toValueInfo (Tup3Type t) sz                 = toValueInfo t sz
toValueInfo (Tup4Type t) sz                 = toValueInfo t sz
toValueInfo (Tup5Type t) sz                 = toValueInfo t sz
toValueInfo (Tup6Type t) sz                 = toValueInfo t sz
toValueInfo (Tup7Type t) sz                 = toValueInfo t sz
toValueInfo (Tup8Type t) sz                 = toValueInfo t sz
toValueInfo (Tup9Type t) sz                 = toValueInfo t sz
toValueInfo (Tup10Type t) sz                = toValueInfo t sz
toValueInfo (Tup11Type t) sz                = toValueInfo t sz
toValueInfo (Tup12Type t) sz                = toValueInfo t sz
toValueInfo (Tup13Type t) sz                = toValueInfo t sz
toValueInfo (Tup14Type t) sz                = toValueInfo t sz
toValueInfo (Tup15Type t) sz                = toValueInfo t sz
toValueInfo (MutType a) sz                  = toValueInfo a sz
toValueInfo (RefType a) sz                  = toValueInfo a sz
toValueInfo (ArrayType a) (Range l r :> es)
  = VIProd RangeKind [VIWord32 (Range l r), toValueInfo a es]
toValueInfo (MArrType a) (Range l r :> es)
  = VIProd RangeKind [VIWord32 (Range l r), toValueInfo a es]
toValueInfo (ParType a) sz                  = toValueInfo a sz
toValueInfo (ElementsType a) (Range l r :> es)
  = VIProd RangeKind [VIWord32 (Range l r), toValueInfo a es]
toValueInfo (ConsType a b) (sa,sb) = VIProd TupleKind $ toValueInfo a sa : ss
  where VIProd _ ss = toValueInfo b sb
toValueInfo NilType _ = VIProd TupleKind []
toValueInfo (IVarType a) sz                 = toValueInfo a sz
-- TODO: Maybe keep argument information for FunType.
toValueInfo (FunType a _) (sa, _)           = toValueInfo a sa
toValueInfo (FValType a) sz                 = toValueInfo a sz


{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
#endif

#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE NoStarIsType #-}
#endif

{-# OPTIONS_GHC -fno-warn-deprecations #-}

{-|
Exports modules that Data.Orphans needs. Because Data.Orphans uses several modules
that only need to be in scope for certain versions of GHC, exporting all of the modules
separately eliminates the need to use CPP pragmas for GHC-version-specific imports.
This makes it much easier to be -Wall-compliant.

Note that this module does not export any modules that could introduce name clashes.
-}
module Data.Orphans.Prelude
#if MIN_VERSION_base(4,16,0)
    () where
#else
    ( module OrphansPrelude
    , realPart
    , imagPart
    , Typeable1
    , Typeable2
    , Typeable3
    , Typeable4
    , Typeable5
    , Typeable6
    , Typeable7
    ) where

import Control.Applicative as OrphansPrelude
import Control.Arrow as OrphansPrelude hiding ((+++), first, loop, second)
import Control.Category as OrphansPrelude hiding ((.), id)
import Control.Concurrent.QSem as OrphansPrelude
import Control.Monad as OrphansPrelude hiding (mapM, sequence)
import Control.Monad.Fix as OrphansPrelude

import Data.Bits as OrphansPrelude
import Data.Char as OrphansPrelude
import Data.Complex as OrphansPrelude (Complex(..))
import Data.Data as OrphansPrelude (Data(..), Constr, DataType, mkConstr, mkDataType)
import Data.Fixed as OrphansPrelude
import Data.Int as OrphansPrelude
import Data.List as OrphansPrelude (genericLength)
import Data.Monoid as OrphansPrelude
  hiding ( Any(..)
# if MIN_VERSION_base(4,5,0)
         , (<>)
# endif
         )
import Data.String as OrphansPrelude (IsString)
import Data.Typeable as OrphansPrelude (Typeable)
import Data.Version as OrphansPrelude
import Data.Word as OrphansPrelude

import Foreign.C.Error as OrphansPrelude
import Foreign.C.Types as OrphansPrelude
import Foreign.Marshal.Pool as OrphansPrelude
import Foreign.Ptr as OrphansPrelude
import Foreign.Storable as OrphansPrelude

import GHC.Arr as OrphansPrelude (Ix(..))
import GHC.Base as OrphansPrelude
import GHC.Conc as OrphansPrelude
import GHC.Desugar as OrphansPrelude (AnnotationWrapper)
import GHC.ForeignPtr as OrphansPrelude
import GHC.IO.Buffer as OrphansPrelude
import GHC.IO.BufferedIO as OrphansPrelude (BufferedIO)
import GHC.IO.Device as OrphansPrelude (IODevice, IODeviceType(..), RawIO)
import GHC.IO.Encoding as OrphansPrelude
import GHC.IO.Handle as OrphansPrelude
import GHC.IO.Handle.Types as OrphansPrelude
import GHC.Real as OrphansPrelude (Ratio(..), (%))
import GHC.ST as OrphansPrelude

import Numeric as OrphansPrelude (showHex)

import System.Console.GetOpt as OrphansPrelude
import System.IO as OrphansPrelude
import System.Posix.Internals as OrphansPrelude
import System.Posix.Types as OrphansPrelude

import Text.Printf as OrphansPrelude
import Text.Read as OrphansPrelude

import Unsafe.Coerce as OrphansPrelude (unsafeCoerce)

# if defined(mingw32_HOST_OS)
import GHC.IO.Encoding.CodePage.Table as OrphansPrelude
# endif

# if MIN_VERSION_base(4,4,0)
import Control.Monad.Zip as OrphansPrelude
import GHC.Fingerprint as OrphansPrelude
import GHC.IO.Encoding.Failure as OrphansPrelude

#  if !defined(mingw32_HOST_OS) && !defined(__GHCJS__)
import GHC.Event as OrphansPrelude
#   if !(MIN_VERSION_base(4,7,0))
      hiding (step)
#   endif
#  endif
# endif

# if MIN_VERSION_base(4,5,0)
import GHC.Stack as OrphansPrelude
import GHC.Stats as OrphansPrelude
# endif

# if MIN_VERSION_base(4,6,0)
import Data.Ord as OrphansPrelude (Down(..))
import GHC.GHCi as OrphansPrelude
import GHC.TypeLits as OrphansPrelude hiding (type (*))
# else
import GHC.Exts as OrphansPrelude (Down(..))
# endif

# if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,8,2))
import GHC.IP as OrphansPrelude
# endif

# if MIN_VERSION_base(4,7,0)
import Data.Proxy as OrphansPrelude
import Data.Type.Coercion as OrphansPrelude (Coercion, TestCoercion)
import Data.Type.Equality as OrphansPrelude ((:~:)(..), TestEquality(..))
import GHC.Exts as OrphansPrelude (IsList(..))
import Text.Read.Lex as OrphansPrelude (Number)
# else
import Control.Concurrent.SampleVar as OrphansPrelude
# endif

# if MIN_VERSION_base(4,8,0)
import Data.Bifunctor as OrphansPrelude
import Data.Functor.Identity as OrphansPrelude
#endif

# if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes as OrphansPrelude
import Data.Functor.Compose as OrphansPrelude
import Data.Semigroup as OrphansPrelude (stimesMonoid)
# endif

# if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,12,0))
import Data.List.NonEmpty as OrphansPrelude (NonEmpty(..))
import Data.Semigroup as OrphansPrelude (Semigroup(..))
# endif

# if !(MIN_VERSION_base(4,11,0))
import Data.Typeable ( Typeable1, Typeable2, Typeable3, Typeable4
                     , Typeable5, Typeable6, Typeable7 )
# endif

# if MIN_VERSION_base(4,4,0)
realPart, imagPart :: Complex a -> a
# else
realPart, imagPart :: RealFloat a => Complex a -> a
# endif
realPart (x :+ _) = x
imagPart (_ :+ y) = y

# if MIN_VERSION_base(4,11,0)
type Typeable1 (a :: Type -> Type)                                                 = Typeable a
type Typeable2 (a :: Type -> Type -> Type)                                         = Typeable a
type Typeable3 (a :: Type -> Type -> Type -> Type)                                 = Typeable a
type Typeable4 (a :: Type -> Type -> Type -> Type -> Type)                         = Typeable a
type Typeable5 (a :: Type -> Type -> Type -> Type -> Type -> Type)                 = Typeable a
type Typeable6 (a :: Type -> Type -> Type -> Type -> Type -> Type -> Type)         = Typeable a
type Typeable7 (a :: Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type) = Typeable a
# endif
#endif


{-# OPTIONS -fglasgow-exts #-}

import GHC.Prim;
import Data.Complex;
import Data.Array;
import GHC.Base;

type Complex_type = Complex Double;
type Array_type b = Array Int b;
type Assoc_type a = (Int,a);
type Descr_type = (Int,Int);

w2i x = word2Int# x;
i2w x = int2Word# x;

abortstr str = error ("abort:" ++ str);

delay x = abortstr "delay not implemented";

fix :: (x -> x) -> x;
fix f = fix_f where {fix_f = f fix_f};

force x = x; -- error "force not implemented"

iff :: Bool -> x -> x -> x;
iff b x y = if b then x else y;

iffrev :: x -> x -> Bool -> x;
iffrev y x b = if b then x else y;

miraseq :: x -> y -> y;
miraseq x y = seq_const y x;  -- x should be marked #STRICT
seq_const x y = x;

pair :: [x] -> Bool;
pair [] = False;
pair x = True;

entier :: Double -> Double;
entier x = fromIntegral (floor x);

land_i :: Int -> Int -> Int;
land_i (I# x) (I# y) = I# (w2i (and# (i2w x) (i2w y)));

lnot_i :: Int -> Int;
lnot_i (I# x) = I# (w2i (not# (i2w x)));

lor_i :: Int -> Int -> Int;
lor_i (I# x) (I# y) = I# (w2i (or# (i2w x) (i2w y)));

lshift_i :: Int -> Int -> Int;
lshift_i (I# x) (I# y) = I# (w2i (shiftL# (i2w x) y));

rshift_i :: Int -> Int -> Int;
rshift_i (I# x) (I# y) = I# (w2i (shiftRL# (i2w x) y));

write x = abortstr "write not implemented";

descr :: Int -> Int -> Descr_type;
descr l u = (l,u);

destr_update :: Array_type x -> Int -> x -> Array_type x;
destr_update ar i x = ar // [(i,x)];

indassoc :: Assoc_type x -> Int;
indassoc (i,v) = i;

lowbound :: Descr_type -> Int;
lowbound (l,u) = l;

tabulate :: (Int -> x) -> Descr_type -> Array_type x;
tabulate f (l,u) = array (l,u) [(i, f i) | i <- [l..u]];

upbound :: Descr_type -> Int;
upbound (l,u) = u;

update :: Array_type x -> Int -> x -> Array_type x;
update ar i x = ar // [(i,x)];

valassoc :: Assoc_type x -> x;
valassoc (i,v) = v;


{-# LANGUAGE OverloadedStrings #-}

import Criterion
import Criterion.Main (defaultConfig)
import Criterion.Types (anMean, reportAnalysis, timeLimit, anOutlierVar, ovEffect, OutlierEffect(Moderate))
import Statistics.Types (Estimate(..), ConfInt(..))

import Control.Monad (filterM)
import Control.Exception (catch, throwIO)
import Data.Foldable (for_)
import Data.Traversable (for)
import GHC.Exts (fromString)

import Language.Rust.Data.InputStream (InputStream)
import Language.Rust.Syntax (SourceFile)
import Language.Rust.Parser (readInputStream, Span, parse')

import System.Directory (getCurrentDirectory, listDirectory, createDirectoryIfMissing, doesFileExist, removeFile)
import System.FilePath ((</>), (<.>), takeFileName)
import System.Process (proc, readCreateProcess)
import System.IO.Error (isDoesNotExistError)

import Data.Aeson
import qualified Data.ByteString.Lazy as BL

main :: IO ()
main = do
  -- Open the output log file
  status <- readCreateProcess (proc "git" ["status", "--porcelain"]) ""
  logFileName <- case status of
                   "" -> init <$> readCreateProcess (proc "git" ["rev-parse", "HEAD"]) ""
                   _ -> pure "WIP"

  -- Get the test cases
  workingDirectory <- getCurrentDirectory
  let sampleSources = workingDirectory </> "sample-sources"
      benchIgnore = sampleSources </> ".benchignore"
  benchIgnoreExists <- doesFileExist benchIgnore
  ignore <- if benchIgnoreExists
              then (\f -> map (sampleSources </>) (lines f)) <$> readFile benchIgnore
              else pure []
  entries <- map (sampleSources </>) <$> listDirectory sampleSources
  files <- filterM doesFileExist (filter (`notElem` ignore) entries)

  -- Clear out previous WIP (if there is one)
  catch (removeFile (workingDirectory </> "bench" </> "timings" </> "WIP" <.> "json"))
        (\e -> if isDoesNotExistError e then pure () else throwIO e)

  -- Run 'criterion' tests
  reports <- for files $ \f -> do
    let name = takeFileName f
    putStrLn name
    is <- readInputStream f
    bnch <- benchmarkWith' defaultConfig{ timeLimit = 20 } (nf (parse' :: InputStream -> SourceFile Span) is)
    pure (name, bnch)
  let results = object [ fromString name .= object [ "mean" .= m
                                                   , "lower bound" .= l
                                                   , "upper bound" .= u
                                                   ]
                       | (name,report) <- reports
                       , let Estimate m (ConfInt l u _) = anMean (reportAnalysis report)
                       , ovEffect (anOutlierVar (reportAnalysis report)) < Moderate
                       ]
  for_ [ name | (name,report) <- reports, ovEffect (anOutlierVar (reportAnalysis report)) >= Moderate ] $ \n ->
    putStrLn $ "Benchmark for `" ++ n ++ "' will not be considered since it was inflated"

  -- Save the output to JSON
  createDirectoryIfMissing False (workingDirectory </> "bench" </> "timings")
  let logFile = workingDirectory </> "bench" </> "timings" </> logFileName <.> "json"
  putStrLn $ "writing results to: " ++ logFile
  logFile `BL.writeFile` encode results


{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}

module ComposableSDR.Types
  ( compose
  , addPipe
  , unPipe
  , toArray
  , elemSize
  , sampleFormat
  , Demodulator
  , Pipe(..)
  , ArrayPipe
  , AudioFormat(..)
  , SamplesIQCF32
  , SoapyException(..)
  , Array(..)
  ) where

import           Control.Category                           (Category (..))
import           Prelude                                    hiding ((.))

import           Data.Complex
import           Data.Typeable

import           Foreign.C.Types
import           Foreign.ForeignPtr                         (plusForeignPtr,
                                                             withForeignPtr)
import           Foreign.Ptr

import           Control.Exception                          (Exception)
import           Control.Monad
import qualified Control.Monad.Catch                        as MC
import           Control.Monad.State
import qualified Control.Monad.Trans.Control                as MTC

import qualified Sound.File.Sndfile                         as SF

import qualified Streamly.Internal.Data.Fold.Types          as FL
import           Streamly.Internal.Data.Stream.StreamK.Type (IsStream)
import qualified Streamly.Internal.Memory.Array.Types       as AT (Array (..))
import qualified Streamly.Memory.Array                      as A
import qualified Streamly.Prelude                           as S

data AudioFormat
  = AU
  | WAV
  deriving (Show, Read)

data Pipe m a b = forall r. Pipe
  { _start :: m r
  , _process :: r -> a -> m b
  , _done :: r -> m ()
  }

newtype Array a = Array
  { fromArray :: AT.Array a
  }

instance SF.Buffer Array Float where
  fromForeignPtr fp i n =
    withForeignPtr fp $ \p -> do
      let v =
            AT.Array
              { AT.aStart = fp `plusForeignPtr` i
              , AT.aEnd = p `plusPtr` (i + 4 * n)
              , AT.aBound = p `plusPtr` (i + 4 * n)
              }
      return $ toArray v
  toForeignPtr = return . (\x -> (AT.aStart x, 0, A.length x)) . fromArray

type ArrayPipe m a b = Pipe m (A.Array a) (A.Array b)
type Demodulator = ArrayPipe IO SamplesIQCF32 Float

data SoapyException =
  SoapyException
  deriving (Show, Typeable)

instance Exception SoapyException

type SamplesIQCF32 = Complex CFloat

elemSize :: Int
elemSize = 8

sampleFormat :: String
sampleFormat = "CF32"

toArray :: AT.Array a -> Array a
toArray = Array

compose :: Monad m => Pipe m b c -> Pipe m a b -> Pipe m a c
compose (Pipe start1 process1 done1) (Pipe start2 process2 done2) =
  Pipe start process done
  where
    start = (,) <$> start1 <*> start2
    done (r1, r2) = done2 r2 >> done1 r1
    process (r1, r2) = process2 r2 >=> process1 r1

instance Monad m => Category (Pipe m) where
  id = Pipe (return ()) (const return) (const $ return ())
  (.) = compose

instance Monad m => Functor (Pipe m a) where
  fmap f (Pipe start process done) =
    Pipe start (\r a -> fmap f (process r a)) done

unPipe :: (IsStream t, MonadIO m,
          MTC.MonadBaseControl IO m,
          MC.MonadThrow m) =>
          Pipe m a b -> m (t m a -> t m b, m ())
unPipe (Pipe creat process dest) = do
  r <- creat
  return (S.mapM (process r), dest r)

addPipe :: MonadIO m => Pipe m a b -> FL.Fold m b c -> FL.Fold m a c
addPipe (Pipe creat process dest) (FL.Fold step1 start1 done1) =
  FL.Fold step start done
  where
    start = do
      s <- start1
      r <- creat
      return (s, r, process r)
    done (s, r, _) = do
      dest r
      done1 s
    step (s, r, f) a = do
      b <- f a
      s' <- step1 s b
      return (s', r, f)


{-# LANGUAGE CPP #-}

#ifndef MIN_VERSION_transformers
#define MIN_VERSION_transformers(a,b,c) 1
#endif

#ifndef HASKELL98
# if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
# elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
# endif
# if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
# endif
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Classes
-- Copyright   :  (c) Ross Paterson 2013, Edward Kmett 2014
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  R.Paterson@city.ac.uk
-- Stability   :  experimental
-- Portability :  portable
--
-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to
-- unary and binary type constructors.
--
-- These classes are needed to express the constraints on arguments of
-- transformers in portable Haskell.  Thus for a new transformer @T@,
-- one might write instances like
--
-- > instance (Eq1 f) => Eq1 (T f) where ...
-- > instance (Ord1 f) => Ord1 (T f) where ...
-- > instance (Read1 f) => Read1 (T f) where ...
-- > instance (Show1 f) => Show1 (T f) where ...
--
-- If these instances can be defined, defining instances of the base
-- classes is mechanical:
--
-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1
-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1
-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1
-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1
--
-----------------------------------------------------------------------------

module Data.Functor.Classes (
    -- * Liftings of Prelude classes
    -- ** For unary constructors
    Eq1(..), eq1,
    Ord1(..), compare1,
    Read1(..), readsPrec1,
    Show1(..), showsPrec1,
    -- ** For binary constructors
    Eq2(..), eq2,
    Ord2(..), compare2,
    Read2(..), readsPrec2,
    Show2(..), showsPrec2,
    -- * Helper functions
    -- $example
    readsData,
    readsUnaryWith,
    readsBinaryWith,
    showsUnaryWith,
    showsBinaryWith,
    -- ** Obsolete helpers
    readsUnary,
    readsUnary1,
    readsBinary1,
    showsUnary,
    showsUnary1,
    showsBinary1,
  ) where

import Control.Applicative (Const(Const))
import Data.Functor.Identity (Identity(Identity))
import Data.Monoid (mappend)
#if MIN_VERSION_base(4,7,0)
import Data.Proxy (Proxy(Proxy))
#endif
import Text.Show (showListWith)

import Control.Monad.Trans.Error
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Data.Functor.Compose
import Data.Functor.Constant
import Data.Functor.Product
import Data.Complex (Complex (..))

#if MIN_VERSION_transformers(0,3,0)
import Control.Applicative.Lift
import Control.Applicative.Backwards
import Data.Functor.Reverse
#endif

#ifndef HASKELL98
# if __GLASGOW_HASKELL__ >= 708
import Data.Typeable
# endif
#endif

-- | Lifting of the 'Eq' class to unary type constructors.
class Eq1 f where
    -- | Lift an equality test through the type constructor.
    --
    -- The function will usually be applied to an equality function,
    -- but the more general type ensures that the implementation uses
    -- it to compare elements of the first container with elements of
    -- the second.
    liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool

-- | Lift the standard @('==')@ function through the type constructor.
eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 = liftEq (==)

-- | Lifting of the 'Ord' class to unary type constructors.
class (Eq1 f) => Ord1 f where
    -- | Lift a 'compare' function through the type constructor.
    --
    -- The function will usually be applied to a comparison function,
    -- but the more general type ensures that the implementation uses
    -- it to compare elements of the first container with elements of
    -- the second.
    liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering

-- | Lift the standard 'compare' function through the type constructor.
compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1 = liftCompare compare

-- | Lifting of the 'Read' class to unary type constructors.
class Read1 f where
    -- | 'readsPrec' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument type.
    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)

    -- | 'readList' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument type.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
    liftReadList rp rl = readListWith (liftReadsPrec rp rl 0)

-- | Read a list (using square brackets and commas), given a function
-- for reading elements.
readListWith :: ReadS a -> ReadS [a]
readListWith rp =
    readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])
  where
    readl s = [([],t) | ("]",t) <- lex s] ++
        [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]
    readl' s = [([],t) | ("]",t) <- lex s] ++
        [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]

-- | Lift the standard 'readsPrec' and 'readList' functions through the
-- type constructor.
readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1 = liftReadsPrec readsPrec readList

-- | Lifting of the 'Show' class to unary type constructors.
class Show1 f where
    -- | 'showsPrec' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument type.
    liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        Int -> f a -> ShowS

    -- | 'showList' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument type.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        [f a] -> ShowS
    liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)

-- | Lift the standard 'showsPrec' and 'showList' functions through the
-- type constructor.
showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 = liftShowsPrec showsPrec showList

-- | Lifting of the 'Eq' class to binary type constructors.
class Eq2 f where
    -- | Lift equality tests through the type constructor.
    --
    -- The function will usually be applied to equality functions,
    -- but the more general type ensures that the implementation uses
    -- them to compare elements of the first container with elements of
    -- the second.
    liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool

-- | Lift the standard @('==')@ function through the type constructor.
eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool
eq2 = liftEq2 (==) (==)

-- | Lifting of the 'Ord' class to binary type constructors.
class (Eq2 f) => Ord2 f where
    -- | Lift 'compare' functions through the type constructor.
    --
    -- The function will usually be applied to comparison functions,
    -- but the more general type ensures that the implementation uses
    -- them to compare elements of the first container with elements of
    -- the second.
    liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->
        f a c -> f b d -> Ordering

-- | Lift the standard 'compare' function through the type constructor.
compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering
compare2 = liftCompare2 compare compare

-- | Lifting of the 'Read' class to binary type constructors.
class Read2 f where
    -- | 'readsPrec' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument types.
    liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->
        (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)

    -- | 'readList' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument types.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->
        (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
    liftReadList2 rp1 rl1 rp2 rl2 =
        readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0)

-- | Lift the standard 'readsPrec' function through the type constructor.
readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)
readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList

-- | Lifting of the 'Show' class to binary type constructors.
class Show2 f where
    -- | 'showsPrec' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument types.
    liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS

    -- | 'showList' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument types.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS
    liftShowList2 sp1 sl1 sp2 sl2 =
        showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)

-- | Lift the standard 'showsPrec' function through the type constructor.
showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS
showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList

-- Instances for Prelude type constructors

instance Eq1 Maybe where
    liftEq _ Nothing Nothing = True
    liftEq _ Nothing (Just _) = False
    liftEq _ (Just _) Nothing = False
    liftEq eq (Just x) (Just y) = eq x y

instance Ord1 Maybe where
    liftCompare _ Nothing Nothing = EQ
    liftCompare _ Nothing (Just _) = LT
    liftCompare _ (Just _) Nothing = GT
    liftCompare comp (Just x) (Just y) = comp x y

instance Read1 Maybe where
    liftReadsPrec rp _ d =
         readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])
         `mappend`
         readsData (readsUnaryWith rp "Just" Just) d

instance Show1 Maybe where
    liftShowsPrec _ _ _ Nothing = showString "Nothing"
    liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x

instance Eq1 [] where
    liftEq _ [] [] = True
    liftEq _ [] (_:_) = False
    liftEq _ (_:_) [] = False
    liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys

instance Ord1 [] where
    liftCompare _ [] [] = EQ
    liftCompare _ [] (_:_) = LT
    liftCompare _ (_:_) [] = GT
    liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys

instance Read1 [] where
    liftReadsPrec _ rl _ = rl

instance Show1 [] where
    liftShowsPrec _ sl _ = sl

instance Eq2 (,) where
    liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2

instance Ord2 (,) where
    liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =
        comp1 x1 x2 `mappend` comp2 y1 y2

instance Read2 (,) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((x,y), w) | ("(",s) <- lex r,
                      (x,t)   <- rp1 0 s,
                      (",",u) <- lex t,
                      (y,v)   <- rp2 0 u,
                      (")",w) <- lex v]

instance Show2 (,) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
        showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'

instance (Eq a) => Eq1 ((,) a) where
    liftEq = liftEq2 (==)

instance (Ord a) => Ord1 ((,) a) where
    liftCompare = liftCompare2 compare

instance (Read a) => Read1 ((,) a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a) => Show1 ((,) a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

instance Eq2 Either where
    liftEq2 e1 _ (Left x) (Left y) = e1 x y
    liftEq2 _ _ (Left _) (Right _) = False
    liftEq2 _ _ (Right _) (Left _) = False
    liftEq2 _ e2 (Right x) (Right y) = e2 x y

instance Ord2 Either where
    liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y
    liftCompare2 _ _ (Left _) (Right _) = LT
    liftCompare2 _ _ (Right _) (Left _) = GT
    liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y

instance Read2 Either where
    liftReadsPrec2 rp1 _ rp2 _ = readsData $
         readsUnaryWith rp1 "Left" Left `mappend`
         readsUnaryWith rp2 "Right" Right

instance Show2 Either where
    liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x
    liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x

instance (Eq a) => Eq1 (Either a) where
    liftEq = liftEq2 (==)

instance (Ord a) => Ord1 (Either a) where
    liftCompare = liftCompare2 compare

instance (Read a) => Read1 (Either a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a) => Show1 (Either a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

-- Instances for other functors defined in the base package

instance Eq1 Identity where
    liftEq eq (Identity x) (Identity y) = eq x y

instance Ord1 Identity where
    liftCompare comp (Identity x) (Identity y) = comp x y

instance Read1 Identity where
    liftReadsPrec rp _ = readsData $
         readsUnaryWith rp "Identity" Identity

instance Show1 Identity where
    liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x

instance Eq2 Const where
    liftEq2 eq _ (Const x) (Const y) = eq x y

instance Ord2 Const where
    liftCompare2 comp _ (Const x) (Const y) = comp x y

instance Read2 Const where
    liftReadsPrec2 rp _ _ _ = readsData $
         readsUnaryWith rp "Const" Const

instance Show2 Const where
    liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x

instance (Eq a) => Eq1 (Const a) where
    liftEq = liftEq2 (==)
instance (Ord a) => Ord1 (Const a) where
    liftCompare = liftCompare2 compare
instance (Read a) => Read1 (Const a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList
instance (Show a) => Show1 (Const a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

#if MIN_VERSION_base(4,7,0)
instance Eq1 Proxy where
    liftEq _ _ _ = True

instance Ord1 Proxy where
    liftCompare _ _ _ = EQ

instance Show1 Proxy where
    liftShowsPrec _ _ _ _ = showString "Proxy"

instance Read1 Proxy where
    liftReadsPrec _ _ d =
        readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])
#endif

-- Building blocks

-- | @'readsData' p d@ is a parser for datatypes where each alternative
-- begins with a data constructor.  It parses the constructor and
-- passes it to @p@.  Parsers for various constructors can be constructed
-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with
-- @mappend@ from the @Monoid@ class.
readsData :: (String -> ReadS a) -> Int -> ReadS a
readsData reader d =
    readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]

-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor
-- and then parses its argument using @rp@.
readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith rp name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- rp 11 s]

-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary
-- data constructor and then parses its arguments using @rp1@ and @rp2@
-- respectively.
readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->
    String -> (a -> b -> t) -> String -> ReadS t
readsBinaryWith rp1 rp2 name cons kw s =
    [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]

-- | @'showsUnaryWith' sp n d x@ produces the string representation of a
-- unary data constructor with name @n@ and argument @x@, in precedence
-- context @d@.
showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith sp name d x = showParen (d > 10) $
    showString name . showChar ' ' . sp 11 x

-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string
-- representation of a binary data constructor with name @n@ and arguments
-- @x@ and @y@, in precedence context @d@.
showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->
    String -> Int -> a -> b -> ShowS
showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $
    showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y

-- Obsolete building blocks

-- | @'readsUnary' n c n'@ matches the name of a unary data constructor
-- and then parses its argument using 'readsPrec'.
{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-}
readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t
readsUnary name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]

-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor
-- and then parses its argument using 'readsPrec1'.
{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-}
readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t
readsUnary1 name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]

-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor
-- and then parses its arguments using 'readsPrec1'.
{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-}
readsBinary1 :: (Read1 f, Read1 g, Read a) =>
    String -> (f a -> g a -> t) -> String -> ReadS t
readsBinary1 name cons kw s =
    [(cons x y,u) | kw == name,
        (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]

-- | @'showsUnary' n d x@ produces the string representation of a unary data
-- constructor with name @n@ and argument @x@, in precedence context @d@.
{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-}
showsUnary :: (Show a) => String -> Int -> a -> ShowS
showsUnary name d x = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec 11 x

-- | @'showsUnary1' n d x@ produces the string representation of a unary data
-- constructor with name @n@ and argument @x@, in precedence context @d@.
{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-}
showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS
showsUnary1 name d x = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec1 11 x

-- | @'showsBinary1' n d x y@ produces the string representation of a binary
-- data constructor with name @n@ and arguments @x@ and @y@, in precedence
-- context @d@.
{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-}
showsBinary1 :: (Show1 f, Show1 g, Show a) =>
    String -> Int -> f a -> g a -> ShowS
showsBinary1 name d x y = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec1 11 x .
        showChar ' ' . showsPrec1 11 y

instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where
    liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y

instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where
    liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y

instance (Read e, Read1 m) => Read1 (ErrorT e m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show e, Show1 m) => Show1 (ErrorT e m) where
    liftShowsPrec sp sl d (ErrorT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1
instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1
instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where
    readsPrec = readsPrec1
instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where
    showsPrec = showsPrec1

instance (Eq1 f) => Eq1 (IdentityT f) where
    liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y

instance (Ord1 f) => Ord1 (IdentityT f) where
    liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y

instance (Read1 f) => Read1 (IdentityT f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT

instance (Show1 f) => Show1 (IdentityT f) where
    liftShowsPrec sp sl d (IdentityT m) =
        showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m

instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1
instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1

instance (Eq1 m) => Eq1 (ListT m) where
    liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y

instance (Ord1 m) => Ord1 (ListT m) where
    liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y

instance (Read1 m) => Read1 (ListT m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show1 m) => Show1 (ListT m) where
    liftShowsPrec sp sl d (ListT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1
instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1
instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1
instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1

instance (Eq1 m) => Eq1 (MaybeT m) where
    liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y

instance (Ord1 m) => Ord1 (MaybeT m) where
    liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y

instance (Read1 m) => Read1 (MaybeT m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show1 m) => Show1 (MaybeT m) where
    liftShowsPrec sp sl d (MaybeT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1
instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1
instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1
instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1

instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where
    liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) =
        liftEq (liftEq2 eq (==)) m1 m2

instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where
    liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) =
        liftCompare (liftCompare2 comp compare) m1 m2

instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT
      where
        rp' = liftReadsPrec2 rp rl readsPrec readList
        rl' = liftReadList2 rp rl readsPrec readList

instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where
    liftShowsPrec sp sl d (Lazy.WriterT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m
      where
        sp' = liftShowsPrec2 sp sl showsPrec showList
        sl' = liftShowList2 sp sl showsPrec showList

instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where
    (==) = eq1
instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where
    compare = compare1
instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where
    readsPrec = readsPrec1
instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where
    showsPrec = showsPrec1

instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where
    liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) =
        liftEq (liftEq2 eq (==)) m1 m2

instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where
    liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) =
        liftCompare (liftCompare2 comp compare) m1 m2

instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT
      where
        rp' = liftReadsPrec2 rp rl readsPrec readList
        rl' = liftReadList2 rp rl readsPrec readList

instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where
    liftShowsPrec sp sl d (Strict.WriterT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m
      where
        sp' = liftShowsPrec2 sp sl showsPrec showList
        sl' = liftShowList2 sp sl showsPrec showList

instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where
    (==) = eq1
instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where
    compare = compare1
instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where
    readsPrec = readsPrec1
instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where
    showsPrec = showsPrec1

instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
    liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y

instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
    liftCompare comp (Compose x) (Compose y) =
        liftCompare (liftCompare comp) x y

instance (Read1 f, Read1 g) => Read1 (Compose f g) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show1 f, Show1 g) => Show1 (Compose f g) where
    liftShowsPrec sp sl d (Compose x) =
        showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
    (==) = eq1
instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
    compare = compare1
instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
    readsPrec = readsPrec1
instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
    showsPrec = showsPrec1

instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
    liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2

instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
    liftCompare comp (Pair x1 y1) (Pair x2 y2) =
        liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2

instance (Read1 f, Read1 g) => Read1 (Product f g) where
    liftReadsPrec rp rl = readsData $
        readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair

instance (Show1 f, Show1 g) => Show1 (Product f g) where
    liftShowsPrec sp sl d (Pair x y) =
        showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y

instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
    where (==) = eq1
instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
    compare = compare1
instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
    readsPrec = readsPrec1
instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
    showsPrec = showsPrec1

instance Eq2 Constant where
    liftEq2 eq _ (Constant x) (Constant y) = eq x y
instance Ord2 Constant where
    liftCompare2 comp _ (Constant x) (Constant y) = comp x y
instance Read2 Constant where
    liftReadsPrec2 rp _ _ _ = readsData $
         readsUnaryWith rp "Constant" Constant
instance Show2 Constant where
    liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x

instance (Eq a) => Eq1 (Constant a) where
    liftEq = liftEq2 (==)
instance (Ord a) => Ord1 (Constant a) where
    liftCompare = liftCompare2 compare
instance (Read a) => Read1 (Constant a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList
instance (Show a) => Show1 (Constant a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

instance Eq a => Eq (Constant a b) where
    Constant a == Constant b = a == b
instance Ord a => Ord (Constant a b) where
    compare (Constant a) (Constant b) = compare a b
instance (Read a) => Read (Constant a b) where
    readsPrec = readsData $
         readsUnaryWith readsPrec "Constant" Constant
instance (Show a) => Show (Constant a b) where
    showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x

instance Show a => Show (Identity a) where
  showsPrec d (Identity a) = showParen (d > 10) $
    showString "Identity " . showsPrec 11 a
instance Read a => Read (Identity a) where
  readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s])
instance Eq a   => Eq (Identity a) where
  Identity a == Identity b = a == b
instance Ord a  => Ord (Identity a) where
  compare (Identity a) (Identity b) = compare a b

#if MIN_VERSION_transformers(0,3,0)
instance (Eq1 f) => Eq1 (Lift f) where
    liftEq eq (Pure x1) (Pure x2) = eq x1 x2
    liftEq _ (Pure _) (Other _) = False
    liftEq _ (Other _) (Pure _) = False
    liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2

instance (Ord1 f) => Ord1 (Lift f) where
    liftCompare comp (Pure x1) (Pure x2) = comp x1 x2
    liftCompare _ (Pure _) (Other _) = LT
    liftCompare _ (Other _) (Pure _) = GT
    liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2

instance (Read1 f) => Read1 (Lift f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith rp "Pure" Pure `mappend`
        readsUnaryWith (liftReadsPrec rp rl) "Other" Other

instance (Show1 f) => Show1 (Lift f) where
    liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x
    liftShowsPrec sp sl d (Other y) =
        showsUnaryWith (liftShowsPrec sp sl) "Other" d y

instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1

instance (Eq1 f) => Eq1 (Backwards f) where
    liftEq eq (Backwards x) (Backwards y) = liftEq eq x y

instance (Ord1 f) => Ord1 (Backwards f) where
    liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y

instance (Read1 f) => Read1 (Backwards f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards

instance (Show1 f) => Show1 (Backwards f) where
    liftShowsPrec sp sl d (Backwards x) =
        showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x

instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1
instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1

instance (Eq1 f) => Eq1 (Reverse f) where
    liftEq eq (Reverse x) (Reverse y) = liftEq eq x y

instance (Ord1 f) => Ord1 (Reverse f) where
    liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y

instance (Read1 f) => Read1 (Reverse f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse

instance (Show1 f) => Show1 (Reverse f) where
    liftShowsPrec sp sl d (Reverse x) =
        showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x

instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1
instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1
#endif

#ifndef HASKELL98
# if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable Eq1
deriving instance Typeable Eq2
deriving instance Typeable Ord1
deriving instance Typeable Ord2
deriving instance Typeable Read1
deriving instance Typeable Read2
deriving instance Typeable Show1
deriving instance Typeable Show2
# endif
#endif

#if MIN_VERSION_base(4,4,0)
instance Eq1 Complex where
    liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v

instance Read1 Complex where
    liftReadsPrec rdP _ p s = readParen (p > complexPrec) (\s' -> do
      (x, s'')     <- rdP (complexPrec+1) s'
      (":+", s''') <- lex s''
      (y, s'''')   <- rdP (complexPrec+1) s'''
      return (x :+ y, s'''')) s
      where
        complexPrec = 6

instance Show1 Complex where
    liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $
        sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y
      where
        complexPrec = 6
#endif

instance Eq a => Eq2 ((,,) a) where
    liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) =
        u1 == v1 &&
        e1 x1 x2 && e2 y1 y2

instance Ord a => Ord2 ((,,) a) where
    liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) =
        compare u1 v1 `mappend`
        comp1 x1 x2 `mappend` comp2 y1 y2

instance Read a => Read2 ((,,) a) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((e1,e2,e3), y) | ("(",s) <- lex r,
                           (e1,t)  <- readsPrec 0 s,
                           (",",u) <- lex t,
                           (e2,v)  <- rp1 0 u,
                           (",",w) <- lex v,
                           (e3,x)  <- rp2 0 w,
                           (")",y) <- lex x]

instance Show a => Show2 ((,,) a) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2)
        = showChar '(' . showsPrec 0 x1
        . showChar ',' . sp1 0 y1
        . showChar ',' . sp2 0 y2
        . showChar ')'

instance (Eq a, Eq b) => Eq1 ((,,) a b) where
    liftEq = liftEq2 (==)

instance (Ord a, Ord b) => Ord1 ((,,) a b) where
    liftCompare = liftCompare2 compare

instance (Read a, Read b) => Read1 ((,,) a b) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a, Show b) => Show1 ((,,) a b) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

instance (Eq a, Eq b) => Eq2 ((,,,) a b) where
    liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
        u1 == v1 &&
        u2 == v2 &&
        e1 x1 x2 && e2 y1 y2

instance (Ord a, Ord b) => Ord2 ((,,,) a b) where
    liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
        compare u1 v1 `mappend`
        compare u2 v2 `mappend`
        comp1 x1 x2 `mappend` comp2 y1 y2

instance (Read a, Read b) => Read2 ((,,,) a b) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((e1,e2,e3,e4), s9) | ("(",s1) <- lex r,
                               (e1,s2)  <- readsPrec 0 s1,
                               (",",s3) <- lex s2,
                               (e2,s4)  <- readsPrec 0 s3,
                               (",",s5) <- lex s4,
                               (e3,s6)  <- rp1 0 s5,
                               (",",s7) <- lex s6,
                               (e4,s8)  <- rp2 0 s7,
                               (")",s9) <- lex s8]

instance (Show a, Show b) => Show2 ((,,,) a b) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2)
        = showChar '(' . showsPrec 0 x1
        . showChar ',' . showsPrec 0 x2
        . showChar ',' . sp1 0 y1
        . showChar ',' . sp2 0 y2
        . showChar ')'

instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where
    liftEq = liftEq2 (==)

instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where
    liftCompare = liftCompare2 compare

instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

{- $example
These functions can be used to assemble 'Read' and 'Show' instances for
new algebraic types.  For example, given the definition

> data T f a = Zero a | One (f a) | Two a (f a)

a standard 'Read1' instance may be defined as

> instance (Read1 f) => Read1 (T f) where
>     liftReadsPrec rp rl = readsData $
>         readsUnaryWith rp "Zero" Zero `mappend`
>         readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend`
>         readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two

and the corresponding 'Show1' instance as

> instance (Show1 f) => Show1 (T f) where
>     liftShowsPrec sp _ d (Zero x) =
>         showsUnaryWith sp "Zero" d x
>     liftShowsPrec sp sl d (One x) =
>         showsUnaryWith (liftShowsPrec sp sl) "One" d x
>     liftShowsPrec sp sl d (Two x y) =
>         showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y

-}


module Parser
    (
    readExpr
  , parseExpr
  , module X
    ) where
import Text.ParserCombinators.Parsec hiding (spaces)
import System.Environment
import Control.Monad
import Numeric
import Data.Ratio
import Data.Complex
import Data.Array

import Number as X
import LispType as X
import Eval as X

-- | @parse p filePath input@ runs a parser @p@ over Identity without user
-- state. The @filePath@ is only used in error messages and may be the
-- empty string. Returns either a 'ParseError' ('Left')
-- or a value of type @a@ ('Right').
--
-- >  main    = case (parse numbers "" "11, 2, 43") of
-- >             Left err  -> print err
-- >             Right xs  -> print (sum xs)
-- >
-- >  numbers = commaSep integer

-- parse :: (Stream s Identity t)
--       => Parsec s () a -> SourceName -> s -> Either ParseError a
-- parse p = runP p ()

-- |
-- >>> readExpr "hoge"
-- "Found value"
readExpr :: String -> Parser LispVal -> LispVal
readExpr input parser = case parse parser "lisp" input of
  Left  err -> String $ "No match: " ++ show err
  Right val -> val

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> parseNumber
        <|> parseBool
        <|> parseCharacter
        <|> parseQuoted
        <|> parseQuasiQuated
        <|> parseUnQuote
        <|> parseVector
        <|> parseLists

-- 引数で与えられた文字列中のどれか一文字を 認識する
--
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

-- lispのAtom(それ以上分割できないデータ型)をパースする
-- |
-- >>> readExpr "a!fdsafdsa" parseAtom
-- "Found value"
parseAtom :: Parser LispVal
parseAtom = do
  first <- letter <|> symbol
  rest  <- many (letter <|> digit <|> symbol)
  let atom = first : rest
  return $ Atom atom

escapeChars :: Parser Char
escapeChars = do
  _ <- char '\\'
  x <- oneOf "\\\"nrt"
  return $ case x of
    'n' -> '\n'
    'r' -> '\r'
    't' -> '\t'
    _   -> x

-- |
-- >>>readExpr "\"abc\"" parseString
-- "Found value"
parseString :: Parser LispVal
parseString = do
  _ <- char '"'
  x <- many $ escapeChars <|> noneOf("\"" ++ "\\")
  _ <- char '"'
  return $ String x

-- | TDOO : description
-- >>> readExpr "#\\j" parseCharacter
-- "Found value"
-- | TDOO : description
-- >>> readExpr "#\\newline" parseCharacter
-- "Found value"
-- | TDOO : description
-- >>> readExpr "#\\space" parseCharacter
-- "Found value"
parseCharacter :: Parser LispVal
parseCharacter = do
  _     <- try $ string "#\\"
  value <- try (string "newline" <|> string "space")
          <|> do {x <- anyChar; notFollowedBy alphaNum; return [x]}
  return $ Character $ case value of
    "space"   -> ' '
    "newline" -> '\n'
    _         -> head value

-- | TDOO : description
-- >>> readExpr "#t" parseBool
-- "Found value"
-- | TDOO : description
-- >>> readExpr "#f" parseBool
-- "Found value"
parseBool :: Parser LispVal
parseBool = do
  _ <- char '#'
  (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))

parseLists :: Parser LispVal
parseLists = do
  _ <- char '('
  x <- try parseList <|> parseDottedList
  _ <- char ')'
  return x

-- | TDOO : description
-- >>>  readExpr  "(a test)" parseExpr
-- "Found value"
-- | TDOO : description
-- >>>  readExpr  "(a (nested) test)" parseExpr
-- "Found value"
-- | TDOO : description
-- >>>  readExpr  "(a (dotteed . list) test)" parseExpr
-- "Found value"
parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do
  head <- endBy parseExpr spaces
  tail <- char '.' >> spaces >> parseExpr
  return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
  _ <- char '\''
  x <- parseExpr
  return $ List [Atom "quote", x]

-- | TDOO : description
-- >>> readExpr "`(list val val)" parseQuasiQuated
-- "Found value"
parseQuasiQuated :: Parser LispVal
parseQuasiQuated = do
  _ <- char '`'
  x <- parseExpr
  return $ List [Atom "quasiquote", x]

-- | TDOO : description
-- >>> readExpr ",(list val val)" parseUnQuote
-- "Found value"
parseUnQuote :: Parser LispVal
parseUnQuote = do
  _ <- char ','
  x <- parseExpr
  return $ List [Atom "unquote", x]

-- | TDOO : description
-- >>> readExpr "#(1 2 3)" parseVector
-- "Found value"
parseVector :: Parser LispVal
parseVector = do
  _ <- string "#("
  x <- try parseVector'
  _ <- char ')'
  return x

parseVector' :: Parser LispVal
parseVector' = do
  arrayValues <- sepBy parseExpr spaces
  return $ Vector $ listArray (0, length arrayValues - 1 ) arrayValues


{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Magma.TH where
import Control.Applicative
import Control.Arrow
import Control.Monad ((>=>), join, void)

import GHC.Exts (groupWith)

import Language.Haskell.TH as TH
import Language.C
import Language.C.System.GCC

import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import Data.Char (toLower, toUpper)
import Data.Maybe (mapMaybe)

import Debug.Trace
import qualified Foreign.C.Types as C
import qualified Foreign.C.String as C (castCharToCChar, castCCharToChar)
import qualified Foreign as F
import Foreign.Storable.Complex ()
import Data.Complex (Complex(..))

import Data.Either (partitionEithers)
import Data.Maybe (isJust)

import System.FilePath.Posix ((</>))

import qualified Text.Parsec as P

import Foreign.CUDA as FC
import qualified Foreign.CUDA.Runtime.Stream as FC

import Foreign.CUDA.Magma.Types

try :: [(Bool, a)] -> a
try ((p,y):conds) = if p then y else try conds
try [] = error "TH.try: No match!"

data TypeInfo = TI
  { ctype    :: Q Type
  , hsinput  :: Either Convert Create
  , hsoutput :: Maybe (Either Convert Destroy) }

data TypeDat = TD
  { ct    :: Q Type
  , hst   :: Q Type
  , c2hs  :: (Q Exp, ExpType)
  , hs2c  :: (Q Exp, ExpType) }

data ExpType = Pure | Monadic

data TypeC = VoidC | IntC | CharC | FloatC | DoubleC | EnumC String
           | ComplexC TypeC | ArbStructC String | PtrC TypeC | HPtrC TypeC | PhonyC TH.Name
           | ArrC TypeC
           deriving (Eq, Show)

prim :: Q Type -> Q Type -> Q Exp -> Q Exp -> TypeDat
prim ct hst c2hs hs2c = TD ct hst (c2hs, Pure) (hs2c, Pure)

simple :: Q Type -> TypeDat
simple t = prim t t [| id |] [| id |]

bothc :: (a -> b) -> Complex a -> Complex b
bothc f (a :+ b) = f a :+ f b

typeDat :: TypeC -> TypeDat
typeDat (PhonyC n)  = simple (varT n)
typeDat VoidC       = simple [t| () |]
typeDat (PtrC t)    = prim [t| F.Ptr $(ctype) |] [t| FC.DevicePtr $(ctype) |] [| FC.DevicePtr |]       [| FC.useDevicePtr |] where
  ctype = ct (typeDat t)
typeDat (HPtrC t)    = simple [t| F.Ptr $(ctype) |] where ctype = ct (typeDat t)
typeDat (ArrC t)    = typeDat (PtrC t)
typeDat IntC        = prim [t| C.CInt |]    [t| Int |]    [| fromIntegral |]          [| fromIntegral |]
typeDat CharC       = prim [t| C.CChar |]    [t| Char |]   [| C.castCCharToChar |]       [| C.castCharToCChar |]
typeDat FloatC      = simple [t| C.CFloat |]
typeDat DoubleC     = simple [t| C.CDouble |]
typeDat (EnumC str) = prim [t| C.CInt |] x [| toEnum . fromIntegral |] [| fromIntegral . fromEnum |] where
  x = case str of
     "magma_uplo_t" -> [t| UpLoT |]
     "magma_trans_t" -> [t| TransT |]
     "magma_vec_t" -> [t| VecT |]
     _ -> error ("typeDat.EnumC : Missing type: " ++ str)
typeDat (ArbStructC str) = error "typeDat.ArbstructC"
typeDat (ComplexC t) = prim
  [t| Complex $(ctype) |]
  [t| Complex $(hstype) |]
  [| bothc $(fromC) |]
  [| bothc $(toC) |]
  where
  TD ctype hstype (fromC, Pure) (toC, Pure) = typeDat t

convertT x y = Left (Convert x y)
createT = Right . Create
destroyT = Right . Destroy

data Convert = Convert (Q Type) (Q Exp)
newtype Create = Create (Q Exp)
newtype Destroy = Destroy (Q Exp)

pointerify :: Q Type -> Q Type
pointerify x = [t| F.Ptr $(x) |]

useT :: TypeC -> TypeInfo
useT = useT' . typeDat where
  useT' (TD ct hst c2hs (hs2c,purity)) = TI
    ct
    (convertT hst exp)
    Nothing
    where
    exp = case purity of Pure -> [| return . $(hs2c) |]; Monadic -> hs2c

inT :: TypeC -> TypeInfo
inT (PtrC t) = inT' (typeDat t) where
  inT' (TD ct hst c2hs (hs2c,purity)) = TI
    (pointerify ct)
    (convertT hst exp)
    (Just (destroyT [| F.free |]))
    where
    exp = case purity of Pure -> [| F.new . $(hs2c) |] ; Monadic -> undefined
inT (ArrC t) = inT' (typeDat t) where
  inT' (TD ct hst c2hs (hs2c,purity)) = TI
    (pointerify ct)
    (convertT [t| [ $(hst) ] |] exp)
    (Just (destroyT [| F.free |]))
    where
    exp = case purity of Pure -> [| F.newArray . map $(hs2c) |] ; Monadic -> undefined

outT :: TypeC -> TypeInfo
outT (PtrC t) = outT' (typeDat t) where
  outT' (TD ct hst (c2hs,purity) hs2c) = TI
    ct
    (createT [| F.malloc |])
    (Just (convertT hst [| \p -> do { x <- F.peek p ; F.free p; $(exp) x } |]))
    where
    exp = case purity of Pure -> [| return . $(c2hs) |] ; Monadic -> c2hs

inOutT :: TypeC -> TypeInfo
inOutT (PtrC t) = inOutT' (typeDat t) where
  inOutT' (TD ct hst (c2hs,purity1) (hs2c,purity2)) = TI
    (pointerify ct)
    (convertT hst exp1)
    (Just (convertT hst [| \p -> do { x <- F.peek p ; F.free p; $(exp2) x } |]))
    where
    exp1 = case purity1 of Pure -> [| F.new . $(hs2c) |] ; Monadic -> hs2c
    exp2 = case purity2 of Pure -> [| return . $(c2hs) |] ; Monadic -> c2hs

convert :: CTypeSpecifier a -> TypeC
convert (CVoidType _) = VoidC
convert (CCharType _) = CharC
--CCharType a
--CShortType a
convert (CIntType _) = IntC
--CLongType a
convert (CFloatType _) = FloatC
convert (CDoubleType _) = DoubleC
--CSignedType a
--CUnsigType a
--CBoolType a
--CComplexType a
convert (CTypeDef ident _) = try
  [ (s=="magma_int_t", IntC)
  , (s=="magmaFloatComplex", ComplexC FloatC)
  , (s=="magmaDoubleComplex", ComplexC DoubleC)
  , (True, EnumC s) ]
  where
  s = identToString ident
convert _ = VoidC

convert' :: [CDeclarationSpecifier a] -> TypeC
convert' (CTypeSpec x:_) = convert x
convert' (_:xs) = convert' xs
convert' [] = error "convert': invalid CDeclarationSpecifier list"

typeOf :: (TypeC -> Q Type) -> CDeclaration a -> Q Type
typeOf proj (CDecl basetype [(Just (CDeclr (Just ident) ptrs _ _ _), _, _)] _) =
  foldr f (proj $ convert' basetype) ptrs
  where
  f (CPtrDeclr _ _) b = [t| F.Ptr $(b) |]
  f _ _ = error "haven't implemented other things"

pointerification :: CDeclaration a -> (TypeC -> TypeC)
pointerification (CDecl _ [(Just (CDeclr _ ptrs _ _ _), _, _)] _) = foldr (.) id $ map f ptrs where
  f (CPtrDeclr _ _) = PtrC
  f (CArrDeclr _ _ _) = ArrC
  f _ = id --possible there are other things that should be here?

baseType :: CDeclaration a -> TypeC
baseType (CDecl basetype _ _) = convert' basetype

cType :: CDeclaration a -> TypeC
cType d = (pointerification d) (baseType d)

typeInfo :: String -> CVar -> TypeInfo
typeInfo fn (n, typec) = ($ typec) $ try
  [ (case typec of ArrC _ -> True; _ -> False
      , inT)
  , (n `elem` []
      , inT)
  , (n == "info"
      , outT)
  , (n == "ipiv"
      , const (case typec of PtrC t -> useT (HPtrC t)))
    {- End -}
  , (True
      , useT)
  ]

declName :: CDeclaration a -> Maybe String
declName (CDecl _ [(Just (CDeclr (Just ident) _ _ _ _), _, _)] _) = Just (identToString ident)
declName _ = Nothing

outMarshall :: TypeC -> (Q Exp, Q Type -> Q Type)
outMarshall VoidC = ([| return . snd |], id)
outMarshall x = let hstype = hst $ typeDat x in
  ([| return |], \typ -> [t| ( $(hstype), $(typ) ) |])

createf' :: (String, CFunction) -> Q [Dec]
createf' (foreignname, cf@(fname, rettype, args)) = do
  ins <- mapM (safeName "_in") args
  toCs <- mapM (safeName "_out") args
  (outstatements, (outtypes, outs)) <- second (unzip . filterMaybes) . unzip <$> collect (zip3 args argsTI toCs)
  let instatements = map inMarsh (zip3 argsTI ins toCs)
  ret <- newName "res"
  let runstatement = bindS (varP ret) (foldl f z toCs)
  let returnstatement = [| $(checkStatusExp) ( $(outputConv) $(varE ret), $(tupE (map varE outs)) ) |]
  expr <- doE $ concat [instatements, runstatement:outstatements, [noBindS returnstatement]]
  let usedins = map snd . filter (isused . fst) $ zip argsTI ins
  let fdec = FunD fcall [Clause (map VarP usedins) (NormalB expr) []]
  tdec <- sigD fcall $ funTypeMod checkStatusType argsTI
  return [tdec, fdec]
  where
  safeName :: String -> CVar -> Q TH.Name
  safeName end (s:str, _) = newName (toLower s : str ++ end)

  argsTI = functionTypeInfo cf
  (outputConv, _) = c2hs (typeDat rettype)
  (checkStatusExp, checkStatusType) = outMarshall rettype
  isused (TI _ (Left _) _) = True
  isused _ = False
  fcall = mkName fname
  z = varE (mkName foreignname)
  f x e = appE x (varE e)
  inMarsh (ti,e,e') = case hsinput ti of
    Left (Convert t a) -> bindS (varP e') (appE a (varE e))
    Right (Create a)   -> bindS (varP e') a
  collect ( (arg, TI _ _ (Just cleanup), e) : xs) = do
    e' <- safeName "_out" arg
    let outinfo = case cleanup of
          Left (Convert t a) -> (bindS (varP e') (appE a (varE e)), Just (t, e'))
          Right (Destroy a) ->  (noBindS (appE a (varE e)), Nothing)
    ys <- collect xs
    return (outinfo:ys)
  collect (_:xs) = collect xs
  collect [] = return []
  collecti (TI _ (Left (Convert t _)) _) =
    [t]
  collecti _ = []

magmaFile :: FilePath
magmaFile = MAGMA_INCLUDE_DIR </> "magma.h"

filterMaybes :: [Maybe a] -> [a]
filterMaybes [] = []
filterMaybes (Just x:xs) = x : filterMaybes xs
filterMaybes (Nothing:xs) = filterMaybes xs

funname :: CDeclaration a -> String
funname (CDecl _ [(Just (CDeclr (Just ident ) _ _ _ _), _, _)] _) = identToString ident
funname _ = error "Weird!"

infol :: Show a =>  CDerivedDeclarator a -> Maybe [[String]]
infol (CFunDeclr (Right (ys,_)) _ _) = Just $ map f ys where
  f (CDecl specs _ _) = map show specs
infol _ = Nothing

funArgs :: CDeclarator a -> Maybe [CDeclaration a]
funArgs (CDeclr _ [(CFunDeclr (Right (ys,_)) _ _)] _ _ _) = Just ys
funArgs _ = Nothing

funDecl :: CDeclaration a -> Maybe (CDeclarator a)
funDecl (CDecl _ [(Just declarator, _, _)] _) = Just declarator
funDecl _ = Nothing

maybeFunction :: CDeclaration a -> Maybe (CFunction)
maybeFunction d@(CDecl returnType _ _) = do
  args <- funArgs =<< funDecl d
  retName <- declName d
  argNames <- mapM declName args
  let argTypes = map cType args
  return (retName, convert' returnType, zip argNames argTypes )

maybeExternalDec :: CExternalDeclaration a -> Maybe (CDeclaration a)
maybeExternalDec (CDeclExt d) = Just d
maybeExternalDec _ = Nothing

type CVar = (String, TypeC)
type CFunction = ( String , TypeC , [CVar] )

getFunctions :: FilePath -> IO [CFunction]
getFunctions fp = do
  Right (CTranslUnit xs _) <- parseCFile (newGCC "/usr/bin/gcc") Nothing ["-DHAVE_CUBLAS", "-I" ++ CUDA_INCLUDE_DIR] fp
  return $ mapMaybe (maybeExternalDec >=> maybeFunction) xs

createf :: FilePath -> CFunction -> Q Dec
createf fp (name, ret, args) =
  forImpD cCall safe{-unsafe-} (fp ++ ' ':name) (mkName name) cFunType
  where
  cFunType = foldr f z (map (ct . typeDat . snd) args)
  z = [t| IO $(ct . typeDat $ ret) |]
  f x y = [t| $(x) -> $(y) |]

parse' :: P.Parsec String () a -> String -> Maybe a
parse' p = \str -> case P.parse p "Unknown error" str of
  Right x -> Just x
  Left e -> Nothing

-- ["Magma", [("potrf_gpu", [("spotrf_gpu", spotrf_gpu )])]
sharedDecs :: String -> [CFunction] -> [(String, [Char], [(String, [(String, CFunction)])])]
sharedDecs prefix@(p:ps) xs = [(prefix' ++ "1", "sd", floatDouble), (prefix', "sdcz", all4)] where
  prefix' = toUpper p : ps
  g x@(s,ret,args) = do
    newname <- goodName prefix s
    return (s, (newname, ret, args))
  xs' = mapMaybe g xs
  fst3 (s,_,_) = s
  (floatDouble, all4) = partitionEithers .
    mapMaybe sdFilter . groupWith (tail . fst3 . snd) $ xs'
  sdFilter xs@((_, (newname, _, _)) : _)
    | length xs == 4 = Just $ Right (newname, xs)
    | length xs == 2 = Just $ Left (newname, xs)
    | otherwise      = Nothing

mkClass :: String -> [CFunction] -> Q Dec
mkClass classname xs = classD (return []) className [PlainTV typeName] [] decs where
  className = mkName classname
  typeName = mkName "a"
  decs = map (f . phonifyF) xs
  mkPhony :: TypeC -> TypeC
  mkPhony (PtrC t) = PtrC (mkPhony t)
  mkPhony (ArrC t) = ArrC (mkPhony t)
  mkPhony x = let t' = PhonyC typeName in
    case x of DoubleC -> t'; FloatC -> t'; ComplexC _ -> t'; y -> y
  phonifyF :: CFunction -> CFunction
  phonifyF cf@(name, ret, args) = (name, mkPhony ret, map (second mkPhony) args)
  f cfunc@(name, ret, _) =
     let (_, retTytrans) = outMarshall ret
         funtype = funTypeMod retTytrans (functionTypeInfo cfunc)
     in sigD (mkName (tail name)) funtype

mkClassInstances :: String -> [Char] -> [(String, [(String,CFunction)])] -> [Q Dec]
mkClassInstances classname instances xs = map (\c -> makeInstance c $ map (f c) xs) instances where
  makeInstance c decs = instanceD (return []) classSig (decs) where
    classSig = appT (return . ConT $ mkName classname) (ct . typeDat $ typeMap c)
  f c (_, funcs) = (!! 1) <$> createf' (foreignn, (name, ret, args)) where
    [(foreignn,((_:name), ret, args))] = filter (\(_,((s:_),_,_))-> s==c) funcs

typeMap :: Char -> TypeC
typeMap 'c' = ComplexC FloatC
typeMap 'z' = ComplexC DoubleC
typeMap 'd' = DoubleC
typeMap 's' = FloatC
typeMap _ = error "typeMap: Invalid character"

makeClassDecs :: String -> FilePath -> IO (Q [Dec])
makeClassDecs str fp = do
  sds <- sharedDecs str <$> getFunctions fp
  return . sequence $ concat
   [ mkClass classname (map (snd . head . snd) funcs) : mkClassInstances classname instances funcs
     | (classname, instances, funcs) <- sds ]

makeFFIDecs :: String -> FilePath -> IO (Q [Dec])
makeFFIDecs str fp = sequence . map (createf fp) . filter (desired str) <$> getFunctions fp

makeAllFuncs :: String -> FilePath -> IO (Q [Dec])
makeAllFuncs str fp = fmap concat . sequence . mapMaybe (fmap createf' . alter) . filter (desired str) <$> getFunctions fp where
  alter (fname, rettype, args) = do
    newname <- goodName str fname
    return (fname, (newname, rettype, args))

goodName :: String -> String -> Maybe String
goodName prefix = parse' $ do
    P.string prefix
    P.char '_'
    char <- P.oneOf "sdcz"
    res <- P.choice $ map (P.try . P.string)
      ["gelqf", "gels3", {-"geqp3",-} "geqrf", "geqrs", "gesv", "getrf", "getrs", "potrf"
      , "potrs", "sposv", "syevd" ]
    P.string "_gpu"
    return (char : res)

desired :: String -> CFunction -> Bool
desired prefix = \(name, _, _) -> isJust $ goodName prefix name

doIO :: IO (Q [a]) -> Q [a]
doIO = join . runIO

inTypes :: [TypeInfo] -> [Q Type]
inTypes = mapMaybe f where
  f (TI _ (Left (Convert t _)) _) = Just t
  f _ = Nothing

outTypes :: [TypeInfo] -> [Q Type]
outTypes = mapMaybe f where
  f (TI _ _ (Just (Left (Convert t _)))) = Just t
  f _ = Nothing

functionTypeInfo :: CFunction -> [TypeInfo]
functionTypeInfo (fname, ret, args) = map (typeInfo fname) args

funTypeMod :: (Q Type -> Q Type) -> [TypeInfo] -> Q Type
funTypeMod f args = foldr arrow z ins where
  arrow x y = [t| $(x) -> $(y) |]
  z = [t| IO $( f $ foldl appT (tupleT (length outs)) outs) |]
  [ins, outs] = map ($ args) [inTypes, outTypes]

funType :: [TypeInfo] -> Q Type
funType = funTypeMod id


{-# language TemplateHaskell #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language TypeOperators #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Eq.StableName.Instances ( ) where

import Control.Applicative (liftA2, ZipList)
import Control.Concurrent.Chan (Chan)
import Control.Concurrent.MVar (MVar)
import Control.Exception
import Data.Char (GeneralCategory)
import Data.Complex (Complex)
import Data.Data (TyCon, Fixity, Constr, Proxy, ConstrRep, DataRep)
import Data.Eq.StableName.Class (StableNameEq, (==$), ($==))
import Data.Eq.StableName.TH (deriveStableNameEq)
import Data.Fixed (Fixed)
import Data.Function (on)
import Data.Functor.Compose (Compose(Compose), getCompose)
import Data.Functor.Const (Const)
import Data.Functor.Identity (Identity)
import Data.Functor.Product (Product(Pair))
import Data.Functor.Sum (Sum(InL, InR))
import Data.IORef (IORef)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Ord (Down)
import Data.Ratio (Ratio)
import Data.STRef (STRef)
import Data.Type.Coercion (Coercion)
import Data.Type.Equality ((:~:), (:~~:))
import Data.Unique (Unique)
import Data.Version (Version)
import Data.Void (Void)
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C.Error (Errno)
import Foreign.C.Types
import Foreign.Ptr (IntPtr, WordPtr, Ptr, FunPtr)
import GHC.Conc (BlockReason, ThreadId, TVar, ThreadStatus)
import GHC.Event (Lifetime, TimeoutKey, FdKey, Event)
import GHC.ExecutionStack (SrcLoc)
import GHC.Exts (SpecConstrAnnotation)
import GHC.Fingerprint (Fingerprint)
import GHC.ForeignPtr (ForeignPtr)
import GHC.Generics
import GHC.IO.Buffer (BufferState)
import GHC.IO.Device (SeekMode, IODeviceType)
import GHC.IO.Encoding.Types (CodingProgress)
import GHC.IO.Handle (Newline, Handle, NewlineMode, BufferMode, HandlePosn)
import GHC.Stable (StablePtr)
import GHC.TypeLits (SomeSymbol)
import GHC.TypeNats (SomeNat)
import GHC.Types (Module, TrName)
import Numeric.Natural (Natural)
import System.Exit (ExitCode)
import System.IO (IOMode)
import System.IO.Error (IOErrorType)
import System.Mem.StableName (StableName)
import System.Posix.Types
import Text.Read.Lex (Number, Lexeme)
import Type.Reflection (SomeTypeRep, TypeRep)
import qualified Data.Monoid
import qualified Data.Semigroup

instance StableNameEq Bool                        where (==$) = eq
instance StableNameEq Ordering                    where (==$) = eq
instance StableNameEq Char                        where (==$) = eq
instance StableNameEq Float                       where (==$) = eq
instance StableNameEq Double                      where (==$) = eq
instance StableNameEq Int                         where (==$) = eq
instance StableNameEq Int8                        where (==$) = eq
instance StableNameEq Int16                       where (==$) = eq
instance StableNameEq Int32                       where (==$) = eq
instance StableNameEq Int64                       where (==$) = eq
instance StableNameEq Integer                     where (==$) = eq
instance StableNameEq Natural                     where (==$) = eq
instance StableNameEq Word                        where (==$) = eq
instance StableNameEq Word8                       where (==$) = eq
instance StableNameEq Word16                      where (==$) = eq
instance StableNameEq Word32                      where (==$) = eq
instance StableNameEq Word64                      where (==$) = eq
instance StableNameEq SomeTypeRep                 where (==$) = eq
instance StableNameEq TyCon                       where (==$) = eq
instance StableNameEq Module                      where (==$) = eq
instance StableNameEq TrName                      where (==$) = eq
instance StableNameEq GeneralCategory             where (==$) = eq
instance StableNameEq IOMode                      where (==$) = eq
instance StableNameEq IntPtr                      where (==$) = eq
instance StableNameEq WordPtr                     where (==$) = eq
instance StableNameEq CUIntMax                    where (==$) = eq
instance StableNameEq CIntMax                     where (==$) = eq
instance StableNameEq CUIntPtr                    where (==$) = eq
instance StableNameEq CIntPtr                     where (==$) = eq
instance StableNameEq CSUSeconds                  where (==$) = eq
instance StableNameEq CUSeconds                   where (==$) = eq
instance StableNameEq CTime                       where (==$) = eq
instance StableNameEq CClock                      where (==$) = eq
instance StableNameEq CSigAtomic                  where (==$) = eq
instance StableNameEq CWchar                      where (==$) = eq
instance StableNameEq CSize                       where (==$) = eq
instance StableNameEq CPtrdiff                    where (==$) = eq
instance StableNameEq CDouble                     where (==$) = eq
instance StableNameEq CFloat                      where (==$) = eq
instance StableNameEq CBool                       where (==$) = eq
instance StableNameEq CULLong                     where (==$) = eq
instance StableNameEq CLLong                      where (==$) = eq
instance StableNameEq CULong                      where (==$) = eq
instance StableNameEq CLong                       where (==$) = eq
instance StableNameEq CUInt                       where (==$) = eq
instance StableNameEq CInt                        where (==$) = eq
instance StableNameEq CUShort                     where (==$) = eq
instance StableNameEq CShort                      where (==$) = eq
instance StableNameEq CUChar                      where (==$) = eq
instance StableNameEq CSChar                      where (==$) = eq
instance StableNameEq CChar                       where (==$) = eq
instance StableNameEq SomeNat                     where (==$) = eq
instance StableNameEq SomeSymbol                  where (==$) = eq
instance StableNameEq DecidedStrictness           where (==$) = eq
instance StableNameEq SourceStrictness            where (==$) = eq
instance StableNameEq SourceUnpackedness          where (==$) = eq
instance StableNameEq Associativity               where (==$) = eq
instance StableNameEq Data.Monoid.Any             where (==$) = eq
instance StableNameEq Data.Monoid.All             where (==$) = eq
instance StableNameEq ArithException              where (==$) = eq
instance StableNameEq IOException                 where (==$) = eq
instance StableNameEq MaskingState                where (==$) = eq
instance StableNameEq BufferState                 where (==$) = eq
instance StableNameEq CodingProgress              where (==$) = eq
instance StableNameEq SeekMode                    where (==$) = eq
instance StableNameEq IODeviceType                where (==$) = eq
instance StableNameEq Newline                     where (==$) = eq
instance StableNameEq Handle                      where (==$) = eq
instance StableNameEq IOErrorType                 where (==$) = eq
instance StableNameEq AsyncException              where (==$) = eq
instance StableNameEq ArrayException              where (==$) = eq
instance StableNameEq Errno                       where (==$) = eq
instance StableNameEq Fd                          where (==$) = eq
instance StableNameEq CTimer                      where (==$) = eq
instance StableNameEq CKey                        where (==$) = eq
instance StableNameEq CId                         where (==$) = eq
instance StableNameEq CFsFilCnt                   where (==$) = eq
instance StableNameEq CFsBlkCnt                   where (==$) = eq
instance StableNameEq CClockId                    where (==$) = eq
instance StableNameEq CBlkCnt                     where (==$) = eq
instance StableNameEq CBlkSize                    where (==$) = eq
instance StableNameEq CRLim                       where (==$) = eq
instance StableNameEq CTcflag                     where (==$) = eq
instance StableNameEq CSpeed                      where (==$) = eq
instance StableNameEq CCc                         where (==$) = eq
instance StableNameEq CUid                        where (==$) = eq
instance StableNameEq CNlink                      where (==$) = eq
instance StableNameEq CGid                        where (==$) = eq
instance StableNameEq CSsize                      where (==$) = eq
instance StableNameEq CPid                        where (==$) = eq
instance StableNameEq COff                        where (==$) = eq
instance StableNameEq CMode                       where (==$) = eq
instance StableNameEq CIno                        where (==$) = eq
instance StableNameEq CDev                        where (==$) = eq
instance StableNameEq Lifetime                    where (==$) = eq
instance StableNameEq Event                       where (==$) = eq
instance StableNameEq BlockReason                 where (==$) = eq
instance StableNameEq ThreadId                    where (==$) = eq
instance StableNameEq TimeoutKey                  where (==$) = eq
instance StableNameEq Unique                      where (==$) = eq
instance StableNameEq Data.Data.Fixity            where (==$) = eq
instance StableNameEq Constr                      where (==$) = eq
instance StableNameEq SpecConstrAnnotation        where (==$) = eq
instance StableNameEq Void                        where (==$) = eq
instance StableNameEq (StablePtr a)               where (==$) = eq
instance StableNameEq (Ptr a)                     where (==$) = eq
instance StableNameEq (FunPtr a)                  where (==$) = eq
instance StableNameEq (MVar a)                    where (==$) = eq
instance StableNameEq (IORef a)                   where (==$) = eq
instance StableNameEq (ForeignPtr a)              where (==$) = eq
instance StableNameEq (TVar a)                    where (==$) = eq
instance StableNameEq (StableName a)              where (==$) = eq
instance StableNameEq (Fixed a)                   where (==$) = eq
instance StableNameEq (V1 p)                      where (==$) = eq
instance StableNameEq (U1 p)                      where (==$) = eq
instance StableNameEq (Type.Reflection.TypeRep a) where (==$) = eq
instance StableNameEq (STRef s a)                 where (==$) = eq
instance StableNameEq (Proxy a)                   where (==$) = eq
instance StableNameEq FdKey                       where (==$) = eq
instance StableNameEq (URec Word p)               where (==$) = eq
instance StableNameEq (URec Int p)                where (==$) = eq
instance StableNameEq (URec Float p)              where (==$) = eq
instance StableNameEq (URec Double p)             where (==$) = eq
instance StableNameEq (URec Char p)               where (==$) = eq
instance StableNameEq (URec (Ptr ()) p)           where (==$) = eq
instance StableNameEq (a :~: b)                   where (==$) = eq
instance StableNameEq (a :~~: b)                  where (==$) = eq
instance StableNameEq (Coercion a b)              where (==$) = eq

eq :: (Eq a) => a -> a -> IO Bool
eq x y = pure (x == y)

instance StableNameEq (f p) => StableNameEq (Rec1 f p) where
    (==$) = ($==) `on` unRec1

instance StableNameEq c => StableNameEq (K1 i c p) where
    (==$) = ($==) `on` unK1

instance StableNameEq (f p) => StableNameEq (M1 i c f p) where
    (==$) = ($==) `on` unM1

instance StableNameEq (f (g p)) => StableNameEq ((:.:) f g p) where
    (==$) = ($==) `on` unComp1

instance (StableNameEq (f p), StableNameEq (g p)) => StableNameEq ((:+:) f g p) where
    L1 f1 ==$ L1 f2 = f1 $== f2
    R1 g1 ==$ R1 g2 = g1 $== g2
    _     ==$ _     = pure False

instance (StableNameEq (f p), StableNameEq (g p)) => StableNameEq ((:*:) f g p) where
    (f1 :*: g1) ==$ (f2 :*: g2) = liftA2 (&&) (f1 $== f2) (g1 $== g2)

instance (StableNameEq (f a), StableNameEq (g a)) => StableNameEq (Data.Functor.Sum.Sum f g a) where
    Data.Functor.Sum.InL f1 ==$ Data.Functor.Sum.InL f2 = f1 $== f2
    Data.Functor.Sum.InR g1 ==$ Data.Functor.Sum.InR g2 = g1 $== g2
    _                       ==$ _      = pure False

instance (StableNameEq (f a), StableNameEq (g a)) => StableNameEq (Product f g a) where
    Pair f1 g1 ==$ Pair f2 g2 = liftA2 (&&) (f1 $== f2) (g1 $== g2)

instance StableNameEq (f (g a)) => StableNameEq (Compose f g a) where
    (==$) = ($==) `on` getCompose

instance (StableNameEq a) => StableNameEq (Data.Semigroup.Arg a b) where
    Data.Semigroup.Arg a _ ==$ Data.Semigroup.Arg b _ = a $== b

concat <$> traverse deriveStableNameEq
  [ ''()
  , ''(,)
  , ''(,,)
  , ''(,,,)
  , ''(,,,,)
  , ''(,,,,,)
  , ''(,,,,,,)
  , ''(,,,,,,,)
  , ''(,,,,,,,,)
  , ''(,,,,,,,,,)
  , ''(,,,,,,,,,,)
  , ''(,,,,,,,,,,,)
  , ''(,,,,,,,,,,,,)
  , ''(,,,,,,,,,,,,,)
  , ''(,,,,,,,,,,,,,,)
  , ''[]
  , ''Maybe
  , ''SrcLoc
  , ''Number
  , ''Lexeme
  , ''Fingerprint
  , ''GHC.Generics.Fixity
  , ''ErrorCall
  , ''NewlineMode
  , ''BufferMode
  , ''ExitCode
  , ''ThreadStatus
  , ''HandlePosn
  , ''Version
  , ''ConstrRep
  , ''DataRep
  , ''Ratio
  , ''Par1
  , ''Down
  , ''Data.Monoid.Last
  , ''Data.Monoid.First
  , ''Data.Monoid.Product
  , ''Data.Monoid.Sum
  , ''Data.Monoid.Dual
  , ''Identity
  , ''ZipList
  , ''Chan
  , ''NonEmpty
  , ''Data.Semigroup.Option
  , ''Data.Semigroup.WrappedMonoid
  , ''Data.Semigroup.Last
  , ''Data.Semigroup.First
  , ''Data.Semigroup.Max
  , ''Data.Semigroup.Min
  , ''Complex
  , ''Either
  , ''Const
  ]