# LANGUAGE GADTs , DataKinds , FlexibleContexts #

# OPTIONS_GHC -Wall #
# OPTIONS_GHC -fno - warn - missing - signatures #

# OPTIONS_GHC -fno - warn - unused - imports #
# OPTIONS_GHC -fno - warn - unused - binds #

----------------------------------------------------------------------
-- |
-- Module      :  Tests
  Copyright    :   ( c ) 2016 Conal Elliott
-- License     :  BSD3
--
-- Maintainer  :  
-- Stability   :  experimental
-- 
-- Experiments. Compile with "ghc -O Tests", and examine Tests.dump-simpl
--
----------------------------------------------------------------------

-- {-# OPTIONS_GHC  -fplugin=LambdaCCC.Plugin #-}
-- {-# OPTIONS_GHC  -fplugin-opt=LambdaCCC.Reify:verbose #-}

-- {-# OPTIONS_GHC -funfolding-use-threshold=0 -ddump-simpl -ddump-to-file -dppr-case-as-let -dsuppress-module-prefixes -dsuppress-idinfo -dsuppress-coercions -dverbose-core2core #-}

-- TODO: Revisit these flags, and perhaps move to Makefile.
-- Do I still want -funfolding-use-threshold=0 ?

module Tests where

-- TODO: explicit exports

import Control.Applicative (liftA2)

import ShapedTypes.Nat
import ShapedTypes.Pair
import ShapedTypes.Vec
import qualified ShapedTypes.RPow as R
import qualified ShapedTypes.LPow as L
import ShapedTypes.Scan
import ShapedTypes.FFT

import qualified ShapedTypes.Fams as F

type Unop  a = a -> a
type Binop a = a -> Unop a

type RTree = R.Pow Pair
type LTree = L.Pow Pair

  foo : :  a = > a - > a
-- foo = (+ 3)

  bar : : ( Foldable f ,  a ) = > f a - > a
-- bar = sum

  baz : :  
-- baz = (&&)

  vec2I : :   
  vec2I = pure 3

  bar : :  a = > Unop ( Tree N1 a )
-- bar = fmap (+1)

-- bar :: Unop (Pair Bool)
-- bar = fmap not

-- bar :: Unop (RTree N4 Bool)
-- bar = fmap not

-- fmapT :: Functor (RTree n) => (a -> b) -> RTree (S n) a -> RTree (S n) b
-- fmapT f (B ts) = B ((fmap.fmap) f ts)

-- foldMapT :: (Foldable (RTree n), Monoid m) => (a -> m) -> RTree (S n) a -> m
  foldMapT f ( B ts ) = ( foldMap.foldMap ) f ts

-- foldMapT1 :: (Foldable (RTree Z), Monoid m) => (a -> m) -> RTree (S Z) a -> m
  foldMapT1 f ( B ts ) = ( foldMap.foldMap ) f ts

-- foo :: Monoid m => (a -> m) -> RTree Z a -> m
-- foo = foldMap

  foo : :  a = > Unop ( RTree ( S ( S Z ) ) a )
-- foo = fmap (+1)

  foo : :  a = > Unop ( RTree ( S ( S ( S ( S ( S ( S ( S ( S ( S ( S ( S Z ) ) ) ) ) ) ) ) ) ) ) a )

  foo : : Unop a - > Unop (  N2 a )
-- foo = fmap

-- foo :: Unop (RTree N2 Bool)
-- foo = fmap not

  foo = pure True : :   

  foo = liftA2 ( + ) : :  ( RTree N1 Int )

  foo : :  a = >  ( RTree N1 a )
-- foo = liftA2 (+)

  foo : :  (    )
-- foo = liftA2 (+)

  foo : :   ( Int - > Bool ) - > RTree N3 Int - > RTree N3 Bool
-- foo = (<*>)

  foo : :    >  ( RTree N5 Bool )
-- foo = liftA2

  foo : :  a - >  ( RTree N3 a )
-- foo = liftA2

foo = sequenceA :: Pair (RTree N6 Int) -> RTree N6 (Pair Int)

  -- Without SPECIALIZE : 0.66 second , 100 definitions ( 1118 lines ) , 32 specialization rules
  -- SPECIALIZE to 4 : 0.5 second , 52 definitions ( 549 lines ) , 21 specialization rules
  -- SPECIALIZE to 8 : 0.3 second , 1 definition ( 11 lines ) , 0 specialization rules
  foo = sequenceA : :   ( RTree N8 Int ) - > RTree N8 ( RTree N7 Int )

  -- 1.0 second , 192 Core definitions ( 2352 lines ) , 79 specialization rules
  foo = sequenceA : :   ( RTree N16 Int ) - > RTree N16 ( RTree N15 Int )

  -- 2.6 seconds , 43 Core definitions ( 884 lines ) , 24 specialization rules
  foo = sequenceA : :   ( RTree N16 Int ) - > RTree N16 ( Vec N15 Int )

  -- 21.2 seconds , 1 definition ( 2149 lines ) , no specialization rules .
  foo = sequenceA : :   ( Vec N16 Int ) - >   ( Vec N15 Int )

--------------------------------------------------------------------
 |
 Module      :  Tests
 License     :  BSD3

 Maintainer  :  
 Stability   :  experimental
 
 Experiments. Compile with "ghc -O Tests", and examine Tests.dump-simpl

--------------------------------------------------------------------
 {-# OPTIONS_GHC  -fplugin=LambdaCCC.Plugin #-}
 {-# OPTIONS_GHC  -fplugin-opt=LambdaCCC.Reify:verbose #-}
 {-# OPTIONS_GHC -funfolding-use-threshold=0 -ddump-simpl -ddump-to-file -dppr-case-as-let -dsuppress-module-prefixes -dsuppress-idinfo -dsuppress-coercions -dverbose-core2core #-}
 TODO: Revisit these flags, and perhaps move to Makefile.
 Do I still want -funfolding-use-threshold=0 ?
 TODO: explicit exports
 foo = (+ 3)
 bar = sum
 baz = (&&)
 bar = fmap (+1)
 bar :: Unop (Pair Bool)
 bar = fmap not
 bar :: Unop (RTree N4 Bool)
 bar = fmap not
 fmapT :: Functor (RTree n) => (a -> b) -> RTree (S n) a -> RTree (S n) b
 fmapT f (B ts) = B ((fmap.fmap) f ts)
 foldMapT :: (Foldable (RTree n), Monoid m) => (a -> m) -> RTree (S n) a -> m
 foldMapT1 :: (Foldable (RTree Z), Monoid m) => (a -> m) -> RTree (S Z) a -> m
 foo :: Monoid m => (a -> m) -> RTree Z a -> m
 foo = foldMap
 foo = fmap (+1)
 foo = fmap
 foo :: Unop (RTree N2 Bool)
 foo = fmap not
 foo = liftA2 (+)
 foo = liftA2 (+)
 foo = (<*>)
 foo = liftA2
 foo = liftA2
 Without SPECIALIZE : 0.66 second , 100 definitions ( 1118 lines ) , 32 specialization rules
 SPECIALIZE to 4 : 0.5 second , 52 definitions ( 549 lines ) , 21 specialization rules
 SPECIALIZE to 8 : 0.3 second , 1 definition ( 11 lines ) , 0 specialization rules
 1.0 second , 192 Core definitions ( 2352 lines ) , 79 specialization rules
 2.6 seconds , 43 Core definitions ( 884 lines ) , 24 specialization rules
 21.2 seconds , 1 definition ( 2149 lines ) , no specialization rules .
# LANGUAGE GADTs , DataKinds , FlexibleContexts #

# OPTIONS_GHC -Wall #
# OPTIONS_GHC -fno - warn - missing - signatures #

# OPTIONS_GHC -fno - warn - unused - imports #
# OPTIONS_GHC -fno - warn - unused - binds #

  Copyright    :   ( c ) 2016 Conal Elliott




module Tests where


import Control.Applicative (liftA2)

import ShapedTypes.Nat
import ShapedTypes.Pair
import ShapedTypes.Vec
import qualified ShapedTypes.RPow as R
import qualified ShapedTypes.LPow as L
import ShapedTypes.Scan
import ShapedTypes.FFT

import qualified ShapedTypes.Fams as F

type Unop  a = a -> a
type Binop a = a -> Unop a

type RTree = R.Pow Pair
type LTree = L.Pow Pair

  foo : :  a = > a - > a

  bar : : ( Foldable f ,  a ) = > f a - > a

  baz : :  

  vec2I : :   
  vec2I = pure 3

  bar : :  a = > Unop ( Tree N1 a )




  foldMapT f ( B ts ) = ( foldMap.foldMap ) f ts

  foldMapT1 f ( B ts ) = ( foldMap.foldMap ) f ts


  foo : :  a = > Unop ( RTree ( S ( S Z ) ) a )

  foo : :  a = > Unop ( RTree ( S ( S ( S ( S ( S ( S ( S ( S ( S ( S ( S Z ) ) ) ) ) ) ) ) ) ) ) a )

  foo : : Unop a - > Unop (  N2 a )


  foo = pure True : :   

  foo = liftA2 ( + ) : :  ( RTree N1 Int )

  foo : :  a = >  ( RTree N1 a )

  foo : :  (    )

  foo : :   ( Int - > Bool ) - > RTree N3 Int - > RTree N3 Bool

  foo : :    >  ( RTree N5 Bool )

  foo : :  a - >  ( RTree N3 a )

foo = sequenceA :: Pair (RTree N6 Int) -> RTree N6 (Pair Int)

  foo = sequenceA : :   ( RTree N8 Int ) - > RTree N8 ( RTree N7 Int )

  foo = sequenceA : :   ( RTree N16 Int ) - > RTree N16 ( RTree N15 Int )

  foo = sequenceA : :   ( RTree N16 Int ) - > RTree N16 ( Vec N15 Int )

  foo = sequenceA : :   ( Vec N16 Int ) - >   ( Vec N15 Int )
