text:
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
#else
{-# OPTIONS_GHC -fcontext-stack=50 #-}
#endif
-- | Instances for 'Generic' and 'HasMetadata'.
--
-- We define instances for datatypes from @generics-sop@ and
-- @base@ that are supported.
--
-- (There are only instances defined in this module, so the
-- documentation is empty.)
--
module Generics.SOP.Instances () where

import Control.Exception
import Data.Char
import Data.Complex
import Data.Data
import Data.Fixed
import Data.Monoid
import Data.Ord
#if !(MIN_VERSION_base(4,7,0))
import Data.Proxy
#endif
import Data.Version
import Foreign.C.Error
import Foreign.C.Types
import System.Console.GetOpt
import System.Exit
import System.IO
#if MIN_VERSION_base(4,7,0)
import Text.Printf
#endif
import Text.Read.Lex

import Generics.SOP.BasicFunctors
import Generics.SOP.TH

-- Types from Generics.SOP:

deriveGeneric ''I
deriveGeneric ''K
deriveGeneric ''(:.:)

-- Cannot derive instances for Sing
-- Cannot derive instances for Shape
-- Cannot derive instances for NP, NS, POP, SOP
-- Cannot derive instances for metadata types

-- Types from the Prelude:

deriveGeneric ''Bool
deriveGeneric ''Ordering
deriveGeneric ''Maybe
deriveGeneric ''Either
deriveGeneric ''()
deriveGeneric ''(,)              -- 2
deriveGeneric ''(,,)
deriveGeneric ''(,,,)
deriveGeneric ''(,,,,)           -- 5
deriveGeneric ''(,,,,,)
deriveGeneric ''(,,,,,,)
deriveGeneric ''(,,,,,,,)
deriveGeneric ''(,,,,,,,,)
deriveGeneric ''(,,,,,,,,,)      -- 10
deriveGeneric ''(,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,) -- 15
deriveGeneric ''(,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
deriveGeneric ''[]

-- Other types from base:

-- From Control.Exception:
deriveGeneric ''IOException
deriveGeneric ''ArithException
deriveGeneric ''ArrayException
deriveGeneric ''AssertionFailed
deriveGeneric ''AsyncException
deriveGeneric ''NonTermination
deriveGeneric ''NestedAtomically
deriveGeneric ''BlockedIndefinitelyOnMVar
deriveGeneric ''BlockedIndefinitelyOnSTM
deriveGeneric ''Deadlock
deriveGeneric ''NoMethodError
deriveGeneric ''PatternMatchFail
deriveGeneric ''RecConError
deriveGeneric ''RecSelError
deriveGeneric ''RecUpdError
deriveGeneric ''ErrorCall
deriveGeneric ''MaskingState

-- From Data.Char:
deriveGeneric ''GeneralCategory

-- From Data.Complex:
deriveGeneric ''Complex

-- From Data.Data:
deriveGeneric ''DataRep
deriveGeneric ''Fixity
deriveGeneric ''ConstrRep

-- From Data.Fixed:
deriveGeneric ''Fixed

-- From Data.Monoid:
deriveGeneric ''Dual
deriveGeneric ''Endo
deriveGeneric ''All
deriveGeneric ''Any
deriveGeneric ''Sum
deriveGeneric ''Product
deriveGeneric ''First
deriveGeneric ''Last

-- From Data.Ord:
deriveGeneric ''Down

-- From Data.Proxy:
deriveGeneric ''Proxy

-- From Data.Version:
deriveGeneric ''Version

-- From Foreign.C.Error:
deriveGeneric ''Errno

-- From Foreign.C.Types:
deriveGeneric ''CChar
deriveGeneric ''CSChar
deriveGeneric ''CUChar
deriveGeneric ''CShort
deriveGeneric ''CUShort
deriveGeneric ''CInt
deriveGeneric ''CUInt
deriveGeneric ''CLong
deriveGeneric ''CULong
deriveGeneric ''CPtrdiff
deriveGeneric ''CSize
deriveGeneric ''CWchar
deriveGeneric ''CSigAtomic
deriveGeneric ''CLLong
deriveGeneric ''CULLong
deriveGeneric ''CIntPtr
deriveGeneric ''CUIntPtr
deriveGeneric ''CIntMax
deriveGeneric ''CUIntMax
deriveGeneric ''CClock
deriveGeneric ''CTime
deriveGeneric ''CUSeconds
deriveGeneric ''CSUSeconds
deriveGeneric ''CFloat
deriveGeneric ''CDouble

-- From System.Console.GetOpt:

deriveGeneric ''ArgOrder
deriveGeneric ''OptDescr
deriveGeneric ''ArgDescr

-- From System.Exit:

deriveGeneric ''ExitCode

-- From System.IO:

deriveGeneric ''IOMode
deriveGeneric ''BufferMode
deriveGeneric ''SeekMode
deriveGeneric ''Newline
deriveGeneric ''NewlineMode

-- From Text.Printf:

#if MIN_VERSION_base(4,7,0)
deriveGeneric ''FieldFormat
deriveGeneric ''FormatAdjustment
deriveGeneric ''FormatSign
deriveGeneric ''FormatParse
#endif

-- From Text.Read.Lex:

deriveGeneric ''Lexeme
#if MIN_VERSION_base(4,7,0)
deriveGeneric ''Number
#endif

-- Abstract / primitive datatypes (we don't derive Generic for these):
--
-- Ratio
-- Integer
-- ThreadId
-- Chan
-- MVar
-- QSem
-- QSemN
-- DataType
-- Dynamic
-- IORef
-- TypeRep
-- TyCon
-- TypeRepKey
-- KProxy -- not abstract, but intended for kind-level use
-- STRef
-- Unique
-- ForeignPtr
-- CFile
-- CFpos
-- CJmpBuf
-- Pool
-- Ptr
-- FunPtr
-- IntPtr
-- WordPtr
-- StablePtr
-- Char
-- Double
-- Float
-- Int
-- Int8
-- Int16
-- Int32
-- Int64
-- Word
-- Word8
-- Word16
-- Word32
-- Word64
-- IO
-- ST
-- (->)
-- RealWorld
-- Handle
-- HandlePosn
-- TextEncoding
-- StableName
-- Weak
-- ReadP
-- ReadPrec
--
-- Datatypes we cannot currently handle:
--
-- SomeException
-- SomeAsyncException
-- Handler
-- Coercion
-- (:~:)

max_stars_repo_name: harpocrates/generics-sop

max_issues_repo_name: harpocrates/generics-sop

max_forks_repo_name: harpocrates/generics-sop


text:
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.FullyConnected where

import           Data.Constraint               (Dict (..))
import           Data.Kind                     (Type)
import           Data.Proxy
import           Data.Singletons               ()
import qualified Data.Vector.Storable          as V
import           GHC.TypeLits
import           Hedgehog
import qualified Numeric.LinearAlgebra.Static  as LA
import           Test.Hedgehog.Compat
import           Test.Hedgehog.Hmatrix
import           Unsafe.Coerce                 (unsafeCoerce)

import           Grenade.Core
import           Grenade.Layers.FullyConnected
import           Grenade.Layers.Internal.BLAS
import           Grenade.Utils.ListStore

data OpaqueFullyConnected :: Type where
     OpaqueFullyConnected :: (KnownNat i, KnownNat o, KnownNat (i * o)) => FullyConnected i o -> OpaqueFullyConnected

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

genOpaqueFullyConnected :: Gen OpaqueFullyConnected
genOpaqueFullyConnected = do
  input :: Integer <- choose 2 100
  output :: Integer <- choose 1 100
  variant <- choose 1 2
  let Just input' = someNatVal input
  let Just output' = someNatVal output
  case (input', output') of
    (SomeNat (Proxy :: Proxy i'), SomeNat (Proxy :: Proxy o')) ->
      case (unsafeCoerce (Dict :: Dict ()) :: Dict (KnownNat (i' * o'))) of
        Dict -> do
          wB <- randomVector
          bM <- randomVector
          wN <- uniformSample
          kM <- uniformSample
          let wInTmp = V.replicate (fromIntegral input) 0
              wBTmp = V.replicate (fromIntegral output) 0
              wNTmp = V.replicate (fromIntegral $ input * output) 0
          return . OpaqueFullyConnected $ case variant of
            1 -> (FullyConnected (FullyConnectedHMatrix wB wN) (ListStore 0 [Just $ FullyConnectedHMatrix bM kM]) (TempVectors wInTmp wBTmp wNTmp) :: FullyConnected i' o')
            2 ->
              let wB' = LA.extract wB
                  bM' = LA.extract bM
                  ext m = V.concat $ map LA.extract (LA.toRows m)
                  wN' = ext wN
                  kM' = ext kM
              in (FullyConnected (FullyConnectedBLAS wB' wN') (ListStore 0 [Just $ FullyConnectedBLAS bM' kM']) (TempVectors wInTmp wBTmp wNTmp) :: FullyConnected i' o')
            _ -> error "unexpected variant in genOpaqueFullyConnected in Test/FullyConnected.hs"

prop_fully_connected_forwards :: Property
prop_fully_connected_forwards = property $ do
    OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected
    input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)
    let (tape, output :: S ('D1 o)) = runForwards fclayer input
        backed :: (Gradient (FullyConnected i o), S ('D1 i))
                                    = runBackwards fclayer tape output
    backed `seq` success

tests :: IO Bool
tests = checkParallel $$(discover)

ext: hs

max_stars_repo_name: schnecki/grenade

max_issues_repo_name: schnecki/grenade

max_forks_repo_name: schnecki/grenade


text:
module DFT (dft, idft) where
import FFT (fft)
import Data.Complex (Complex)
import Data.List (reverse, map, take)

dft :: [Complex Float] -> [Complex Float]
dft [] = []
dft xs = fft $ preprocess xs

idft :: [Complex Float] -> [Complex Float]
idft [] = []
idft xs = (invertFFT . dft) xs

invertFFT :: [Complex Float] -> [Complex Float]
invertFFT [] = []
invertFFT coeffs@(x:xs) = [ x' / n | x' <- (x : reverse xs) ]
  where n = (fromIntegral . length) coeffs

preprocess :: [Complex Float] -> [Complex Float]
preprocess [] = []
preprocess xs = take targetLength (xs ++ (repeat 0))
  where targetLength = 2 ^ ceiling (log ((fromIntegral . length) xs) / log 2)

max_stars_repo_name: gboduljak/dft

max_issues_repo_name: gboduljak/dft

max_forks_repo_name: gboduljak/dft


text:
-- |
-- Module      : BattleHack.Piano
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX

-- Created September 12 2015

-- TODO | - Split up into several modules
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Piano where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Control.Lens hiding (inside)
import Data.List    (find)
import Data.Complex

import BattleHack.Types
import BattleHack.Lenses
import BattleHack.Utilities.Vector
import BattleHack.Utilities.General

--------------------------------------------------------------------------------------------------------------------------------------------
-- Data
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
naturals :: Integral n => [n]
naturals = [0, 2, 4, 5, 7, 9, 11]

-- |
accidentals :: Integral n => [n]
accidentals = [1, 3, 6, 8, 10]

-- | The indeces of every natural key in order, starting at C0 (index 0)
allnaturals :: [Int]
allnaturals = zipWith (\i key -> div i 7 * 12 + key) [0..] $ cycle naturals

-- | The indeces of every accidental key in order, starting at C#0 (index 1)
allaccidentals :: [Int]
allaccidentals = zipWith (\i key -> div i 5 * 12 + key) [0..] $ cycle accidentals

-- |
chordlayout :: [KeyLayout]
chordlayout = [KeyRight, KeyAccidental, KeyBoth, KeyAccidental, KeyLeft, KeyRight, KeyAccidental, KeyBoth, KeyAccidental, KeyBoth, KeyAccidental, KeyLeft]

-- | Horizontal offset for each key in the octave, relative to the very first key
keysteps :: RealFloat r => [r]
keysteps = scanl1 (+) [0, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1]

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
keyorigin :: PianoSettings -> Int -> Vector
keyorigin piano i = piano-->origin + (sx*shiftx :+ 0)
  where
    (sx:+_)  = piano-->keysize
    shiftx   = 7*octaveFromKeyIndex i + (keysteps !! (i `mod` 12))

-- |
keylayout :: Int -> KeyLayout
keylayout i = chordlayout !! (i `mod` 12)

-- | Is the point inside the bounds of the given key?
--   Note that the function assumes that the key is pinned to the origin.
-- TODO: Bugs ahead (swat them!)
-- TODO: Rename (?)
inside :: PianoSettings -> KeyLayout -> Vector -> Bool
inside piano KeyLeft       p = insideBounds piano p && not (insideLeft piano p)
inside piano KeyRight      p = insideBounds piano p && not (insideRight piano p)
inside piano KeyBoth       p = insideBounds piano p && not (insideLeft piano p || insideRight piano p)
inside piano KeyAccidental p = insideMiddle piano p --  --insideLeft   piano p || insideRight piano p

-- | Is the point within the rectangular bounding box of the key?
insideBounds :: PianoSettings -> Vector -> Bool
insideBounds piano (x:+y) = let (dx:+dy) = piano-->keysize in between 0 dx x && between 0 dy y

-- | Is the point within the left indent of the key?
insideLeft :: PianoSettings -> Vector -> Bool
insideLeft  piano (x:+y) = let (dx:+dy) = dotwise (*) (piano-->indent :+ piano-->mid) (piano-->keysize) in between 0 dx x && between 0 dy y

-- | Is the point within the right indent of the key?
-- TODO: Buggy!
insideRight :: PianoSettings -> Vector -> Bool
insideRight piano p = let shiftx = piano-->keysize.real * (piano-->indent - 1) in insideLeft piano $ p + (shiftx:+0)
-- insideRight piano p = let shiftx = piano-->keysize.real * (1 - piano-->indent) in insideLeft piano $ p - (piano-->keysize.real:+0) + ((piano-->keysize.real*piano-->indent):+0)
-- insideRight piano (x:+y) = between ()

-- |
insideMiddle :: PianoSettings -> Vector -> Bool
insideMiddle piano (x:+y) = let (ox:+oy, dx:+dy) = keybounds piano KeyAccidental in between ox (ox+dx) x && between oy (oy+dy) y

-- |
-- TODO: Move to Piano
-- TODO: Rename (?)
layout :: RealFloat r => Complex r -> r -> r -> KeyLayout -> [Complex r]
layout (sx:+sy) indent mid which = case which of
  KeyRight      -> [nw,  nei,  rmi,         rm, se, sw]
  KeyBoth       -> [nwi, nei,  rmi,         rm, se, sw, lm, lmi]
  KeyLeft       -> [nwi, ne,   se,          sw, lm, lmi]
  KeyAccidental -> [nei, rmi,  (sx:+0)+lmi, (sx:+0)+nwi]
  where
    indent' = sx*indent
    mid'    = sy*mid

    nw = 0:+0   -- North west
    ne = sx:+0  -- North east
    se = sx:+sy -- South east
    sw = 0:+sy  -- South west

    nwi = indent':+0       -- North west indented
    nei = (sx-indent'):+0  -- North east indented

    lmi = indent':+mid'      -- Left  middle indent
    rmi = (sx-indent'):+mid' -- Right middle indent

    lm = 0:+mid'  -- Left middle
    rm = sx:+mid' -- Right middle

-- | Rectangular bounds of a key (currently as a topleft, size tuple)
-- TODO: Use Bounding Box type (?)
keybounds :: PianoSettings -> KeyLayout -> (Vector, Vector)
keybounds piano layout = case layout of
  KeyAccidental -> (piano-->keysize.real' - (indent':+0), (2*indent'):+mid')
  _             -> (0:+0, piano-->keysize)
  where
    (indent':+mid') = dotwise (*) (piano-->keysize) (piano-->indent:+piano-->mid)

-- |
-- TODO: Simplify
-- TODO: Don't hard-code the range
-- TODO: This is a pretty dumb algorithm for finding hovered-over keys
findKeyAt :: Vector -> PianoSettings -> Maybe Int
findKeyAt p piano' = find (insideFromKeyIndex piano' p) (zipWith const [0..] (piano'-->keys))

-- | Is the point inside the key at the given index?
-- TODO: Rename (?)
insideFromKeyIndex :: PianoSettings -> Vector -> Int -> Bool
insideFromKeyIndex piano' p i = inside piano' (keylayout i) (p-keyorigin piano' i)

-- |
pitchFromKeyIndex :: RealFloat r => Int -> r
pitchFromKeyIndex i = let i' = i+4+49 in 440.0*2.0**((fromIntegral i' - 49)/12.0) -- TODO: Make sure this is correct, elaborate on the meaning of the different index conversions
-- pitchFromKeyIndex i = 440*2**((fromIntegral $ i+3 + 12*4-49)/12)

-- | Which octave does the key belong to (the 0th octave starts with C0, the 1st with C1; no overlap between octaves)
octaveFromKeyIndex :: RealFloat r => Int -> r
octaveFromKeyIndex = fromIntegral . (`div` 12)

-- |
-- TODO: Refactor
-- TODO: Use Unicode (?)
notenameFromKeyIndex :: Int -> String
notenameFromKeyIndex i = ["C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B"] !! mod i 12


text:
{-|
Module: MachineLearning.LogisticModel
Description: Logistic Regression Model
Copyright: (c) Alexander Ignatyev, 2016
License: BSD-3
Stability: experimental
Portability: POSIX

-}

module MachineLearning.LogisticModel
(
  module MachineLearning.Model
  , LogisticModel(..)
  , sigmoid
  , sigmoidGradient
)

where

import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra((<>), (#>), (<.>))
import qualified Data.Vector.Storable as V

import MachineLearning.Model
import qualified MachineLearning.Regularization as R

data LogisticModel = Logistic

-- | Calculates sigmoid
sigmoid :: Floating a => a -> a
sigmoid z = 1 / (1+exp(-z))

-- | Calculates derivatives of sigmoid
sigmoidGradient :: Floating a => a -> a
sigmoidGradient z = s * (1-s)
  where s = sigmoid z

instance Model LogisticModel where
  hypothesis Logistic x theta = sigmoid (x #> theta)

  cost m lambda x y theta =
    let h = hypothesis m x theta
        nExamples = fromIntegral $ LA.rows x
        tau = 1e-7
        jPositive = log(tau + h) <.> (-y)
        jNegative = log((1 + tau) - h) <.> (1-y)
        regTerm = R.costReg lambda theta
    in (jPositive - jNegative + regTerm) / nExamples

  gradient m lambda x y theta = (((LA.tr x) #> (h  - y)) + regTerm) / nExamples
    where h = hypothesis m x theta
          nExamples = fromIntegral $ LA.rows x
          regTerm = R.gradientReg lambda theta

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Lib
    ( someFunc
    ) where

import Data.Functor.Foldable
import Data.Functor.Foldable.TH
import Data.List (intercalate, partition, foldl1', foldl', sort, sortOn)
import Data.Sparse.SpMatrix
import Data.Sparse.SpVector
import Numeric.LinearAlgebra.Sparse

a' :: SpMatrix Double
a' = fromListDenseSM 2 [ 1, 3
                      , 1, 1]

b' :: SpVector Double
b' = mkSpVR 2 [1, 3]

data Exp a = Add [Exp a]
           | Mul [Exp a]
           | Lit a
           | Var Char
           deriving (Show, Eq, Ord)

instance (Num a) => Num (Exp a) where
    negate x = (Lit (-1) * x)
    (+) x y = Add [x, y]
    (*) x y = Mul [x, y]
    fromInteger = Lit . fromInteger
    abs = id
    signum = id

makeBaseFunctor ''Exp

simp :: (Num a, Ord a) => Exp a -> Exp a
simp e = cata order . cata dist . cata flatten $ e
    where flatten (MulF as) = let (ms, bs) = partition isMul as
                               in Mul $ concat [ms' | (Mul ms') <- ms ] ++ bs
          flatten (AddF as) = let (ms, bs) = partition isAdd as
                               in Add $ concat [ms' | (Add ms') <- ms ] ++ bs
          flatten x = embed x

          dist (MulF as) = foldl1' (\l r -> Add $ (\l' r' -> flatten $ MulF [l', r']) <$> unAdd l <*> unAdd r) as
          dist (AddF as) = flatten (AddF as)
          dist x = embed x

          order (MulF as) = let (ls, ns) = partition isLit as
                             in Mul $ sort ((Lit $ product [ x | (Lit x) <- ls]) : ns)
          order (AddF as) = let adds = sortOn (filter (not . isLit) . unMul) as
                                x = foldl' (\((pl:pns):ps) (al:ans) -> if pns == ans then ((addLit pl al):pns):ps else (al:ans):(pl:pns):ps) [(unMul . head $ adds)] (unMul <$> tail adds)
                             in Add (Mul <$> x)
          order x = embed x

          unAdd (Add as) = as
          unAdd x = [x]

          unMul (Mul as) = as
          unMul x = [x]

          isMul (Mul _) = True
          isMul _ = False

          isAdd (Add _) = True
          isAdd _ = False

          isLit (Lit _) = True
          isLit _ = False

          addLit (Lit l) (Lit r) = Lit (l + r)

p :: (Show a) => [Exp a] -> String
p es = intercalate "\n" (pretty <$> es)

pretty :: (Show a) => Exp a -> String
pretty (Add as) = intercalate " + " (pretty <$> as)
pretty (Mul ms) = concat $ (\m -> case m of
                                     Add _ -> "(" ++ pretty m ++ ")"
                                     _ -> pretty m) <$> ms
pretty (Var c) = [c]
pretty (Lit a) = show a

a = Var 'a'
b = Var 'b'
c = Var 'c'
d = Var 'd'
e = Var 'e'
f = Var 'f'

test = (a + 1)^5

someFunc :: IO ()
someFunc = do
    putStrLn (show test)

max_stars_repo_name: micahhahn/calculus-helpers

max_issues_repo_name: micahhahn/calculus-helpers

max_forks_repo_name: micahhahn/calculus-helpers


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Numeric.QpOases where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.Vector.Storable as VS
import Data.Matrix.CSC
import Foreign hiding (void)
import Foreign.C.Types
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Devel

data OasesError = SizeMismatch | OasesError Int deriving (Show)

data HessianType = HST_ZERO | HST_IDENTITY | HST_POSDEF | HST_POSDEF_NULLSPACE | HST_SEMIDEF | HST_INDEF | HST_UNKNOWN deriving (Enum, Show)

newtype SQProblem = SQProblem (ForeignPtr SQProblem) deriving (Eq, Show)

newtype SQProblemSchur = SQProblemSchur (ForeignPtr SQProblemSchur) deriving (Eq, Show)

setupSQP :: Int -> Int -> HessianType -> IO SQProblem
setupSQP nV nC h = do
    ptr2 <- alloca $ \ptr -> do
        !_ <- sqproblem_setup (fromIntegral nV) (fromIntegral nC) (fromIntegral $ fromEnum h) ptr
        peek ptr
    SQProblem <$> newForeignPtr sqproblem_cleanup ptr2

setupSQPSchur :: Int -> Int -> HessianType -> IO SQProblemSchur
setupSQPSchur nV nC h = do
    ptr2 <- alloca $ \ptr -> do
        !_ <- sqproblem_schur_setup (fromIntegral nV) (fromIntegral nC) (fromIntegral $ fromEnum h) ptr
        peek ptr
    SQProblemSchur <$> newForeignPtr sqproblem_schur_cleanup ptr2

withSQProblem :: SQProblem -> (Ptr SQProblem -> IO a) -> IO a
withSQProblem (SQProblem fPtr) f = withForeignPtr fPtr f

withSQProblemSchur :: SQProblemSchur -> (Ptr SQProblemSchur -> IO a) -> IO a
withSQProblemSchur (SQProblemSchur fPtr) f = withForeignPtr fPtr f

initSQP :: SQProblem -> Matrix Double -> Vector Double -> Matrix Double
        -> Vector Double -> Vector Double -> Maybe Double
        -> ExceptT OasesError IO (Vector Double, Double)
initSQP sqp h g a lbA ubA m'cpuTime =
  mat' h $ \hRow hCol hPtr ->
  vec' g $ \gSize gPtr ->
  mat' a $ \aRow aCol aPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = aRow
    unless (nVar == hRow) $ throwE SizeMismatch
    unless (nVar == hCol) $ throwE SizeMismatch
    unless (nVar == aCol) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr ->
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblem sqp $ \ptr ->
               sqproblem_init ptr hPtr gPtr aPtr nullPtr nullPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

initSparseSQP :: SQProblem -> CSC Double -> Vector Double -> Matrix Double
              -> Vector Double -> Vector Double -> Maybe Double
              -> ExceptT OasesError IO (Vector Double, Double)
initSparseSQP sqp h g a lbA ubA m'cpuTime =
  vec' (cscVals h) $ \_hValsSize hValsPtr ->
  vec' (cscCols h) $ \_hColsSize hColsPtr ->
  vec' (cscRows h) $ \_hRowsSize hRowsPtr ->
  vec' g $ \gSize gPtr ->
  mat' a $ \aRow aCol aPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = aRow
    unless (nVar == aCol) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr ->
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblem sqp $ \ptr ->
               sqproblem_sparse_init ptr hRowsPtr hColsPtr hValsPtr gPtr aPtr
               nullPtr nullPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

initSparseSQPSchur :: SQProblemSchur -> CSC Double -> Vector Double -> Matrix Double
                   -> Vector Double -> Vector Double -> Maybe Double
                   -> ExceptT OasesError IO (Vector Double, Double)
initSparseSQPSchur sqp h g a lbA ubA m'cpuTime =
  vec' (cscVals h) $ \_hValsSize hValsPtr ->
  vec' (cscCols h) $ \_hColsSize hColsPtr ->
  vec' (cscRows h) $ \_hRowsSize hRowsPtr ->
  vec' g $ \gSize gPtr ->
  mat' a $ \aRow aCol aPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = aRow
    unless (nVar == aCol) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr ->
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblemSchur sqp $ \ptr ->
               sqproblem_sparse_schur_init ptr hRowsPtr hColsPtr hValsPtr gPtr aPtr
               nullPtr nullPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

initSparseSparseSQPSchur :: SQProblemSchur -> CSC Double -> Vector Double -> CSC Double
                   -> Maybe (Vector Double) -> Maybe (Vector Double)
                   -> Vector Double -> Vector Double -> Maybe Double
                   -> ExceptT OasesError IO (Vector Double, Double)
initSparseSparseSQPSchur sqp h g a m'lb m'ub lbA ubA m'cpuTime =
  vec' (cscVals h) $ \_hValsSize hValsPtr ->
  vec' (cscCols h) $ \_hColsSize hColsPtr ->
  vec' (cscRows h) $ \_hRowsSize hRowsPtr ->
  vec' g $ \gSize gPtr ->
  vec' (cscVals a) $ \_aValsSize aValsPtr ->
  vec' (cscCols a) $ \_aColsSize aColsPtr ->
  vec' (cscRows a) $ \_aRowsSize aRowsPtr ->
  maybe (\f -> f undefined nullPtr) vec' m'lb $ \_lbSize lbPtr ->
  maybe (\f -> f undefined nullPtr) vec' m'ub $ \_ubSize ubPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = cscNRows a
    unless (nVar == cscNCols a) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr ->
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblemSchur sqp $ \ptr ->
               sqproblem_sparse_sparse_schur_init ptr hRowsPtr hColsPtr hValsPtr gPtr
               aRowsPtr aColsPtr aValsPtr
               lbPtr ubPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

hotstartSQP :: SQProblem -> Matrix Double -> Vector Double -> Matrix Double
            -> Vector Double -> Vector Double -> Maybe Double
            -> ExceptT OasesError IO (Vector Double, Double)
hotstartSQP sqp h g a lbA ubA m'cpuTime =
  mat' h $ \hRow hCol hPtr ->
  vec' g $ \gSize gPtr ->
  mat' a $ \aRow aCol aPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = aRow
    unless (nVar == hRow) $ throwE SizeMismatch
    unless (nVar == hRow) $ throwE SizeMismatch
    unless (nVar == hCol) $ throwE SizeMismatch
    unless (nVar == aCol) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr ->
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblem sqp $ \ptr ->
               sqproblem_hotstart ptr hPtr gPtr aPtr nullPtr nullPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

hotstartSparseSQP :: SQProblem -> CSC Double -> Vector Double -> Matrix Double
                  -> Vector Double -> Vector Double -> Maybe Double
                  -> ExceptT OasesError IO (Vector Double, Double)
hotstartSparseSQP sqp h g a lbA ubA m'cpuTime =
  vec' (cscVals h) $ \_hValsSize hValsPtr ->
  vec' (cscCols h) $ \_hColsSize hColsPtr ->
  vec' (cscRows h) $ \_hRowsSize hRowsPtr ->
  vec' g $ \gSize gPtr ->
  mat' a $ \aRow aCol aPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = aRow
    unless (nVar == aCol) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr -> do
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblem sqp $ \ptr ->
               sqproblem_sparse_hotstart ptr hRowsPtr hColsPtr hValsPtr gPtr
               aPtr nullPtr nullPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

hotstartSparseSQPSchur :: SQProblemSchur -> CSC Double -> Vector Double -> Matrix Double
                  -> Vector Double -> Vector Double -> Maybe Double
                  -> ExceptT OasesError IO (Vector Double, Double)
hotstartSparseSQPSchur sqp h g a lbA ubA m'cpuTime =
  vec' (cscVals h) $ \_hValsSize hValsPtr ->
  vec' (cscCols h) $ \_hColsSize hColsPtr ->
  vec' (cscRows h) $ \_hRowsSize hRowsPtr ->
  vec' g $ \gSize gPtr ->
  mat' a $ \aRow aCol aPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = aRow
    unless (nVar == aCol) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr ->
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblemSchur sqp $ \ptr ->
               sqproblem_sparse_schur_hotstart ptr hRowsPtr hColsPtr hValsPtr gPtr
               aPtr nullPtr nullPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

hotstartSparseSparseSQPSchur :: SQProblemSchur -> CSC Double -> Vector Double -> CSC Double
                  -> Maybe (Vector Double) -> Maybe (Vector Double) -> Vector Double -> Vector Double -> Maybe Double
                  -> ExceptT OasesError IO (Vector Double, Double)
hotstartSparseSparseSQPSchur sqp h g a m'lb m'ub lbA ubA m'cpuTime =
  vec' (cscVals h) $ \_hValsSize hValsPtr ->
  vec' (cscCols h) $ \_hColsSize hColsPtr ->
  vec' (cscRows h) $ \_hRowsSize hRowsPtr ->
  vec' g $ \gSize gPtr ->
  vec' (cscVals a) $ \_aValsSize aValsPtr ->
  vec' (cscCols a) $ \_aColsSize aColsPtr ->
  vec' (cscRows a) $ \_aRowsSize aRowsPtr ->
  maybe (\f -> f undefined nullPtr) vec' m'lb $ \_lbSize lbPtr ->
  maybe (\f -> f undefined nullPtr) vec' m'ub $ \_ubSize ubPtr ->
  vec' lbA $ \lbASize lbAPtr ->
  vec' ubA $ \ubASize ubAPtr -> do
    let nVar = gSize
    let nConstr = cscNRows a
    unless (nVar == cscNCols a) $ throwE SizeMismatch
    unless (nConstr == lbASize) $ throwE SizeMismatch
    unless (nConstr == ubASize) $ throwE SizeMismatch
    primalFP <- liftIO $ mallocForeignPtrArray (fromIntegral nVar)
    (obj, status) <- liftIO $ withForeignPtr primalFP $ \xPtr ->
      allocaArray (fromIntegral $ nVar + nConstr) $ \yPtr ->
      alloca $ \objPtr ->
      alloca $ \statusPtr ->
      with (5 * fromIntegral (nVar + nConstr)) $ \nWSRPtr ->
      maybe ($ nullPtr) with m'cpuTime $ \cpuTimePtr -> do
        _ <- withSQProblemSchur sqp $ \ptr ->
               sqproblem_sparse_sparse_schur_hotstart ptr hRowsPtr hColsPtr hValsPtr gPtr
               aRowsPtr aColsPtr aValsPtr lbPtr ubPtr lbAPtr ubAPtr
               nWSRPtr cpuTimePtr xPtr yPtr objPtr statusPtr
        !obj <- peek objPtr
        !status <- fromIntegral <$> peek statusPtr
        return $ (obj, status)
    let solutionVec = VS.unsafeFromForeignPtr0 primalFP (fromIntegral nVar)
    if status == 0
      then return (solutionVec, obj)
      else throwE (OasesError status)
  where
    mat' m f = ExceptT $ mat (cmat m) $ \church -> church $ \nrow ncol ptr -> runExceptT $ f nrow ncol ptr
    vec' v f = ExceptT $ vec v $ \church -> church $ \size ptr -> runExceptT $ f size ptr

data Options

foreign import ccall "sqproblem_init"
    sqproblem_init
        :: Ptr SQProblem -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_sparse_init"
    sqproblem_sparse_init
        :: Ptr SQProblem -> Ptr CInt -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_sparse_schur_init"
    sqproblem_sparse_schur_init
        :: Ptr SQProblemSchur -> Ptr CInt -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_sparse_sparse_schur_init"
    sqproblem_sparse_sparse_schur_init
        :: Ptr SQProblemSchur -> Ptr CInt -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr CInt -> Ptr CInt -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_hotstart"
    sqproblem_hotstart
        :: Ptr SQProblem -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_sparse_hotstart"
    sqproblem_sparse_hotstart
        :: Ptr SQProblem -> Ptr CInt -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_sparse_schur_hotstart"
    sqproblem_sparse_schur_hotstart
        :: Ptr SQProblemSchur -> Ptr CInt -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_sparse_sparse_schur_hotstart"
    sqproblem_sparse_sparse_schur_hotstart
        :: Ptr SQProblemSchur -> Ptr CInt -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr CInt -> Ptr CInt -> Ptr Double -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double
        -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr CInt -> IO CInt

foreign import ccall "sqproblem_setup"
    sqproblem_setup
        :: CInt -> CInt -> CInt -> Ptr (Ptr SQProblem)-> IO CInt

foreign import ccall "sqproblem_schur_setup"
    sqproblem_schur_setup
        :: CInt -> CInt -> CInt -> Ptr (Ptr SQProblemSchur)-> IO CInt

foreign import ccall "&sqproblem_cleanup"
    sqproblem_cleanup
        :: FunPtr (Ptr SQProblem -> IO ())

foreign import ccall "&sqproblem_schur_cleanup"
    sqproblem_schur_cleanup
        :: FunPtr (Ptr SQProblemSchur -> IO ())


text:
-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Low-level bindings to core R datatypes and functions. Nearly all structures
-- allocated internally in R are instances of a 'SEXPREC'. A pointer to
-- a 'SEXPREC' is called a 'SEXP'.
--
-- To allow for precise typing of bindings to primitive R functions, we index
-- 'SEXP's by 'SEXPTYPE', which classifies the /form/ of a 'SEXP' (see
-- "Foreign.R.Type"). A function accepting 'SEXP' arguments of any type should
-- leave the type index uninstantiated. A function returning a 'SEXP' result of
-- unknown type should use 'SomeSEXP'. (More precisely, unknown types in
-- /negative/ position should be /universally/ quantified and unknown types in
-- /positive/ position should be /existentially/ quantified).
--
-- This module is intended to be imported qualified.

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE DeriveDataTypeable #-}
#endif
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- Warns about some sanity checks like IsVector, that has no methods and are
-- not used.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Foreign.R
  ( module Foreign.R.Type
    -- * Internal R structures
  , SEXP(..)
  , SomeSEXP(..)
  , unSomeSEXP
    -- * Casts and coercions
    -- $cast-coerce
  , cast
  , asTypeOf
  , unsafeCoerce
    -- * Node creation
  , allocSEXP
  , allocList
  , allocVector
  , allocVectorProtected
  , install
  , mkString
  , mkChar
  , CEType(..)
  , mkCharCE
  , mkCharLenCE
  , mkWeakRef
    -- * Node attributes
  , typeOf
  , isS4
  , setAttributes
  , getAttribute
  , getAttributes
    -- * Node accessor functions
    -- ** Lists
  , cons
  , lcons
  , car
  , cdr
  , tag
  , setCar
  , setCdr
  , setTag
    -- ** Environments
  , envFrame
  , envEnclosing
  , envHashtab
    -- ** Closures
  , closureFormals
  , closureBody
  , closureEnv
    -- ** Promises
  , promiseCode
  , promiseEnv
  , promiseValue
    -- ** Symbols
  , symbolPrintName
  , symbolValue
  , symbolInternal
    -- ** Vectors
  , length
  , trueLength
  , char
  , real
  , integer
  , logical
  , complex
  , raw
  , string
  , unsafeSEXPToVectorPtr
  , unsafeVectorPtrToSEXP
  , readVector
  , writeVector
    -- * Evaluation
  , eval
  , tryEval
  , tryEvalSilent
  , lang1
  , lang2
  , lang3
  , findFun
  , findVar
    -- * GC functions
  , protect
  , unprotect
  , unprotectPtr
  , preserveObject
  , releaseObject
  , gc
    -- * Globals
  , isRInteractive
  , nilValue
  , unboundValue
  , missingArg
  , baseEnv
  , emptyEnv
  , globalEnv
  , signalHandlers
  , interruptsPending
    -- * Communication with runtime
  , printValue
    -- * Low level info header access
  , SEXPInfo(..)
  , peekInfo
  , pokeInfo
  , mark
  , named
  -- * Internal types and functions
  --
  -- | Should not be used in user code. These exports are only needed for
  -- binding generation tools.
  , SEXPREC
  , SEXP0
  , sexp
  , unsexp
  , release
  , unsafeRelease
  , unsafeReleaseSome
  , withProtected
  -- * Deprecated
  , indexVector
  ) where

import Control.Memory.Region
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
import Foreign.R.Internal
import Foreign.R.Type
import Foreign.R.Type as R

import Control.Applicative
import Control.Exception (bracket)
import Data.Complex
import Data.Int (Int32)
#if __GLASGOW_HASKELL__ < 710
import Data.Typeable (Typeable)
#endif
import Foreign (Ptr, castPtr)
import Foreign.C
import Foreign.R.Context (rCtx, SEXP0, SEXPREC)
import qualified Language.C.Inline as C
import Prelude hiding (asTypeOf, length)

#define USE_RINTERNALS
#include <Rinternals.h>

C.context (C.baseCtx <> rCtx)
C.include "<Rinternals.h>"
C.include "<stdlib.h>"
C.include "<stdint.h>"

--------------------------------------------------------------------------------
-- Generic accessor functions                                                 --
--------------------------------------------------------------------------------

-- | read CAR object value
car :: SEXP s a -> IO (SomeSEXP s)
car (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]

-- | read CDR object
cdr :: SEXP s a -> IO (SomeSEXP s)
cdr (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]

-- | read object`s Tag
tag :: SEXP s a -> IO (SomeSEXP s)
tag (unsexp -> s) = somesexp <$> [C.exp| SEXP { TAG( $(SEXP s) ) } |]

--------------------------------------------------------------------------------
-- Environment functions                                                      --
--------------------------------------------------------------------------------

envFrame :: (SEXP s 'R.Env) -> IO (SEXP s R.PairList)
envFrame (unsexp -> s) = sexp <$> [C.exp| SEXP { FRAME( $(SEXP s) ) } |]

-- | Enclosing environment.
envEnclosing :: SEXP s 'R.Env -> IO (SEXP s 'R.Env)
envEnclosing (unsexp -> s) = sexp <$> [C.exp| SEXP { ENCLOS( $(SEXP s) ) } |]

-- | Hash table associated with the environment, used for faster name lookups.
envHashtab :: SEXP s 'R.Env -> IO (SEXP s 'R.Vector)
envHashtab (unsexp -> s) = sexp <$> [C.exp| SEXP { HASHTAB( $(SEXP s) ) } |]

--------------------------------------------------------------------------------
-- Closure functions                                                          --
--------------------------------------------------------------------------------

-- | Closure formals (aka the actual arguments).
closureFormals :: SEXP s 'R.Closure -> IO (SEXP s R.PairList)
closureFormals (unsexp -> s) = sexp <$> [C.exp| SEXP { FORMALS( $(SEXP s) ) }|]

-- | The code of the closure.
closureBody :: SEXP s 'R.Closure -> IO (SomeSEXP s)
closureBody (unsexp -> s) = somesexp <$> [C.exp| SEXP { BODY( $(SEXP s) ) } |]

-- | The environment of the closure.
closureEnv :: SEXP s 'R.Closure -> IO (SEXP s 'R.Env)
closureEnv (unsexp -> s) = sexp <$> [C.exp| SEXP { CLOENV( $(SEXP s) ) }|]

--------------------------------------------------------------------------------
-- Promise functions                                                          --
--------------------------------------------------------------------------------

-- | The code of a promise.
promiseCode :: SEXP s 'R.Promise -> IO (SomeSEXP s)
promiseCode (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRCODE( $(SEXP s) )}|]

-- | The environment in which to evaluate the promise.
promiseEnv :: SEXP s 'R.Promise -> IO (SomeSEXP s)
promiseEnv (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRENV( $(SEXP s) )}|]

-- | The value of the promise, if it has already been forced.
promiseValue :: SEXP s 'R.Promise -> IO (SomeSEXP s)
promiseValue (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRVALUE( $(SEXP s) )}|]

--------------------------------------------------------------------------------
-- Vector accessor functions                                                  --
--------------------------------------------------------------------------------

-- | Read True Length vector field.
trueLength :: R.IsVector a => SEXP s a -> IO CInt
trueLength (unsexp -> s) = [C.exp| int { TRUELENGTH( $(SEXP s) ) }|]

-- | Read character vector data
char :: SEXP s 'R.Char -> IO CString
char (unsexp -> s) = castPtr <$> [C.exp| const char* { CHAR($(SEXP s))}|]
-- XXX: check if we really need Word8 here, maybe some better handling of
-- encoding

-- | Read real vector data.
real :: SEXP s 'R.Real -> IO (Ptr Double)
real (unsexp -> s) = castPtr <$> [C.exp| double* { REAL( $(SEXP s)) }|]

-- | Read integer vector data.
integer :: SEXP s 'R.Int -> IO (Ptr Int32)
integer (unsexp -> s) = [C.exp| int32_t* { INTEGER( $(SEXP s) )}|]

-- | Read raw data.
raw :: SEXP s 'R.Raw -> IO (Ptr CChar)
raw (unsexp -> s) = [C.exp| char* { RAW($(SEXP s)) } |]

-- | Read logical vector data.
logical :: SEXP s 'R.Logical -> IO (Ptr R.Logical)
logical (unsexp -> s) = castPtr <$>
  [C.exp| int* { LOGICAL($(SEXP s)) } |]

-- | Read complex vector data.
complex :: SEXP s 'R.Complex -> IO (Ptr (Complex Double))
complex (unsexp -> s) = [C.exp| Rcomplex* { COMPLEX($(SEXP s)) }|]

-- | Read string vector data.
string :: SEXP s 'R.String -> IO (Ptr (SEXP s 'R.Char))
string (unsexp -> s) = castPtr <$>
  [C.exp| SEXP* { STRING_PTR($(SEXP s)) }|]

readVector :: R.IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)
readVector (unsexp -> s) (fromIntegral -> n) = somesexp <$>
  [C.exp| SEXP { VECTOR_ELT( $(SEXP s), $(int n) ) } |]

indexVector :: IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)
{-# DEPRECATED indexVector "Use readVector instead." #-}
indexVector = readVector

writeVector :: R.IsGenericVector a => SEXP s a -> Int -> SEXP s b -> IO (SEXP s a)
writeVector (unsexp -> a) (fromIntegral -> n) (unsexp -> b) = sexp <$>
  [C.exp| SEXP { SET_VECTOR_ELT($(SEXP a),$(int n), $(SEXP b)) } |]

--------------------------------------------------------------------------------
-- Symbol accessor functions                                                  --
--------------------------------------------------------------------------------

-- | Read a name from symbol.
symbolPrintName :: SEXP s 'R.Symbol -> IO (SEXP s a)
symbolPrintName (unsexp -> s) = sexp <$> [C.exp| SEXP { PRINTNAME( $(SEXP s)) } |]

-- | Read value from symbol.
symbolValue :: SEXP s 'R.Symbol -> IO (SEXP s a)
symbolValue (unsexp -> s) = sexp <$> [C.exp| SEXP { SYMVALUE( $(SEXP s)) } |]

-- | Read internal value from symbol.
symbolInternal :: SEXP s 'R.Symbol -> IO (SEXP s a)
symbolInternal (unsexp -> s) = sexp <$> [C.exp| SEXP { INTERNAL( $(SEXP s)) }|]

--------------------------------------------------------------------------------
-- Value contruction                                                          --
--------------------------------------------------------------------------------

-- | Initialize a new string vector.
mkString :: CString -> IO (SEXP V 'R.String)
mkString value = sexp <$>  [C.exp| SEXP { Rf_mkString($(char * value)) } |]

-- | Initialize a new character vector (aka a string).
mkChar :: CString -> IO (SEXP V 'R.Char)
mkChar value = sexp <$> [C.exp| SEXP { Rf_mkChar($(char * value)) } |]

-- | Create Character value with specified encoding
mkCharCE :: CEType -> CString -> IO (SEXP V 'R.Char)
mkCharCE (cIntFromEnum -> ce) value = sexp <$>
  [C.exp| SEXP  { Rf_mkCharCE($(char * value), $(int ce)) } |]

mkCharLenCE :: CEType -> CString -> Int -> IO (SEXP V 'R.Char)
mkCharLenCE (cIntFromEnum -> ce) value (fromIntegral -> len) = sexp <$>
  [C.exp| SEXP { Rf_mkCharLenCE($(char * value), $(int len), $(int ce)) } |]

-- | Intern a string @name@ into the symbol table.
--
-- If @name@ is not found, it is added to the symbol table. The symbol
-- corresponding to the string @name@ is returned.
install :: CString -> IO (SEXP V 'R.Symbol)
install name = sexp <$>
  [C.exp| SEXP { Rf_install($(char * name)) }|]

-- | Allocate a 'SEXP'.
allocSEXP :: SSEXPTYPE a -> IO (SEXP V a)
allocSEXP (cUIntFromSingEnum -> s) = sexp <$>
  [C.exp| SEXP { Rf_allocSExp( $(unsigned int s) ) }|]

-- | Allocate a pairlist of 'SEXP's, chained together.
allocList :: Int -> IO (SEXP V 'R.List)
allocList (fromIntegral -> n) = sexp <$> [C.exp| SEXP {Rf_allocList($(int n))} |]

-- | Allocate Vector.
allocVector :: R.IsVector a => SSEXPTYPE a -> Int -> IO (SEXP V a)
allocVector (cUIntFromSingEnum -> p) (fromIntegral -> n) = sexp <$>
  [C.exp| SEXP {Rf_allocVector( $(unsigned int p), $(int n)) } |]

allocVectorProtected :: (R.IsVector a) => SSEXPTYPE a -> Int -> IO (SEXP s a)
allocVectorProtected ty n = fmap release (protect =<< allocVector ty n)

-- | Allocate a so-called cons cell, in essence a pair of 'SEXP' pointers.
cons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.List)
cons (unsexp -> a) (unsexp -> b) = sexp <$>
  [C.exp| SEXP { Rf_cons($(SEXP a), $(SEXP b)) }|]

-- | Allocate a so-called cons cell of language objects, in essence a pair of
-- 'SEXP' pointers.
lcons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.Lang)
lcons (unsexp -> a) (unsexp -> b) = sexp <$>
  [C.exp| SEXP { Rf_lcons($(SEXP a), $(SEXP b)) } |]

printValue :: SEXP s a -> IO ()
printValue (unsexp -> s) =
  [C.exp| void { Rf_PrintValue($(SEXP s)) }|]

--------------------------------------------------------------------------------
-- Garbage collection                                                         --
--------------------------------------------------------------------------------

-- | Protect a 'SEXP' from being garbage collected by R. It is in particular
-- necessary to do so for objects that are not yet pointed by any other object,
-- e.g. when constructing a tree bottom-up rather than top-down.
--
-- To avoid unbalancing calls to 'protect' and 'unprotect', do not use these
-- functions directly but use 'Language.R.withProtected' instead.
protect :: SEXP s a -> IO (SEXP G a)
protect (unsexp -> s) = sexp <$>
  [C.exp| SEXP { Rf_protect($(SEXP s)) }|]

-- | @unprotect n@ unprotects the last @n@ objects that were protected.
unprotect :: Int -> IO ()
unprotect (fromIntegral -> i) =
  [C.exp| void { Rf_unprotect($(int i)) } |]

-- | Unprotect a specific object, referred to by pointer.
unprotectPtr :: SEXP G a -> IO ()
unprotectPtr (unsexp -> s) =
  [C.exp| void { Rf_unprotect_ptr($(SEXP s)) }|]

-- | Invoke an R garbage collector sweep.
gc :: IO ()
gc = [C.exp| void { R_gc() }|]

-- | Preserve an object accross GCs.
preserveObject :: SEXP s a -> IO ()
preserveObject (unsexp -> s) =
  [C.exp| void { R_PreserveObject( $(SEXP s) )} |]

-- | Allow GC to remove an preserved object.
releaseObject :: SEXP s a -> IO ()
releaseObject (unsexp -> s) =
  [C.exp| void { R_ReleaseObject( $(SEXP s) )} |]

--------------------------------------------------------------------------------
-- Evaluation                                                                 --
--------------------------------------------------------------------------------

-- | Evaluate any 'SEXP' to its value.
eval :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP V)
eval (unsexp -> expr) (unsexp -> env) = somesexp <$>
  [C.exp| SEXP { Rf_eval($(SEXP expr), $(SEXP env)) }|]

-- | Try to evaluate expression.
tryEval :: SEXP s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)
tryEval (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>
  [C.exp| SEXP { R_tryEval($(SEXP expr), $(SEXP env), $(int* retCode)) }|]

-- | Try to evaluate without printing error/warning messages to stdout.
tryEvalSilent :: SEXP  s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)
tryEvalSilent (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>
  [C.exp| SEXP { R_tryEvalSilent($(SEXP expr), $(SEXP env), $(int* retCode)) }|]

-- | Construct a nullary function call.
lang1 :: SEXP s a -> IO (SEXP V 'R.Lang)
lang1 (unsexp -> s) = sexp <$>
  [C.exp| SEXP {Rf_lang1($(SEXP s)) }|]

-- | Construct unary function call.
lang2 :: SEXP s a -> SEXP s b ->  IO (SEXP V 'R.Lang)
lang2 (unsexp -> f) (unsexp -> x) = sexp <$>
  [C.exp| SEXP {Rf_lang2($(SEXP f), $(SEXP x)) }|]

-- | Construct a binary function call.
lang3 :: SEXP s a -> SEXP s b ->  SEXP s c -> IO (SEXP V 'R.Lang)
lang3 (unsexp -> f) (unsexp -> x) (unsexp -> y) = sexp <$>
  [C.exp| SEXP {Rf_lang3($(SEXP f), $(SEXP x), $(SEXP y)) }|]

-- | Find a function by name.
findFun :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP s)
findFun (unsexp -> a) (unsexp -> env) = somesexp <$>
  [C.exp| SEXP { Rf_findFun($(SEXP a), $(SEXP env)) }|]

-- | Find a variable by name.
findVar :: SEXP s a -> SEXP s 'R.Env -> IO (SEXP s 'R.Symbol)
findVar (unsexp -> a) (unsexp -> env) = sexp <$>
  [C.exp| SEXP {Rf_findVar($(SEXP a), $(SEXP env))}|]

mkWeakRef :: SEXP s a -> SEXP s b -> SEXP s c -> Bool -> IO (SEXP V 'R.WeakRef)
mkWeakRef (unsexp -> a) (unsexp -> b) (unsexp -> c) (cIntFromEnum -> t) = sexp <$>
  [C.exp| SEXP {R_MakeWeakRef($(SEXP a), $(SEXP b), $(SEXP c), $(int t))}|]

-------------------------------------------------------------------------------
-- Encoding                                                                  --
-------------------------------------------------------------------------------

-- | Content encoding.
data CEType
  = CE_Native
  | CE_UTF8
  | CE_Latin1
  | CE_Bytes
  | CE_Symbol
  | CE_Any
  deriving (Eq, Show)

instance Enum CEType where
  fromEnum CE_Native = #const CE_NATIVE
  fromEnum CE_UTF8   = #const CE_UTF8
  fromEnum CE_Latin1 = #const CE_LATIN1
  fromEnum CE_Bytes  = #const CE_BYTES
  fromEnum CE_Symbol = #const CE_SYMBOL
  fromEnum CE_Any    = #const CE_ANY
  toEnum i = case i of
    (#const CE_NATIVE) -> CE_Native
    (#const CE_UTF8)   -> CE_UTF8
    (#const CE_LATIN1) -> CE_Latin1
    (#const CE_BYTES)  -> CE_Bytes
    (#const CE_SYMBOL) -> CE_Symbol
    (#const CE_ANY)    -> CE_Any
    _ -> error "CEType.fromEnum: unknown tag"

-- | Perform an action with resource while protecting it from the garbage
-- collection. This function is a safer alternative to 'R.protect' and
-- 'R.unprotect', guaranteeing that a protected resource gets unprotected
-- irrespective of the control flow, much like 'Control.Exception.bracket_'.
withProtected :: IO (SEXP V a)      -- Action to acquire resource
              -> (SEXP s a -> IO b) -- Action
              -> IO b
withProtected create f =
    bracket
      (do { x <- create; _ <- protect x; return x })
      (const $ unprotect 1)
      (f . unsafeRelease)

ext: hsc

max_stars_repo_name: tweag/HaskellR

max_issues_repo_name: tweag/HaskellR

max_forks_repo_name: tweag/HaskellR


text:
module Main (main) where

import Data.Complex
import Data.HDF5
import Data.Proxy
import Data.Text
import Data.Word
import qualified Data.Vector.Storable as V
import System.IO (IOMode (..))

main :: IO ()
main = do
  -- disableDiagOutput
  withFile "workspace_30.h5" ReadWriteMode $ \handle -> do
    byName handle "/47" . matchM @Group $ \root ->
      do
        -- print =<< getSize handle
        -- print =<< getSize root
        -- print =<< getDims root "c"
        -- () <- byName root "c" $ \(Some x@(Dataset _)) ->
        --   print =<< readDataset' (Proxy @Double) x
        writeAttribute root "random" (12.3 :: Float)
        print =<< readAttribute @Double root "energy"
        print =<< readAttribute @Float root "random"
        writeAttribute root "random" (15.8 :: Float)
        print =<< readAttribute @Float root "random"
        writeAttribute root "cheers" (17.0 :+ (-1.8) :: Complex Float)
        print =<< readAttribute @(Complex Float) root "cheers"
        writeAttribute @Text root "ping pong" "This is awesome!"
        print =<< readAttribute @Text root "ping pong"

        print =<< exists root "c'"
        print =<< exists root "/48/tleft"

        () <- byName root "c" $ \case
          (Some x@(Dataset _)) -> do
            print =<< getDatasetDims x
          _ -> error "expected c to be a dataset"

        () <- byName root "c" $ \case
          (Some x@(Dataset _)) -> do
            blob <- readDataset @Double x
            writeDataset root "p" blob
          _ -> error "expected c to be a dataset"

        writeDataset root "uint64_dataset" $ V.fromList [1 :: Word64, 2, 3]
        return ()

  putStrLn "Hello world!"

-- case hasStorable (Proxy @Float) of
--   Just _ -> print "cheers!"
--   Nothing -> print "fuck!"

-- print =<< readAttribute' (Proxy @Double) root "energy"

-- print =<< h5Name handle
-- print =<< h5FindDataset handle "c"
-- g' <- h5OpenByIndex handle 0
-- print =<< h5Size g'
-- print =<< h5Name g'
-- print =<< h5FindDataset g' "tleft"
-- print =<< h5GetNumDims g' "tleft"
-- print =<< h5GetDatasetInfo g' "c"
-- readTypedDataset (Proxy @Double) g' "c" >>= \case
--   (H5ConcreteBlob v dims) -> print dims
-- readDataset g' "c" >>= \case
--   (H5DoubleBlob v dims) -> print dims
-- _ <- h5FoldlM (\i h -> h5Name h >>= \name -> print (i, name) >> return (i + 1)) 0 g'
-- closeHandle g'


text:
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}

module Verify where

import Feldspar
import Feldspar.Software
import Feldspar.Software.Verify
import Feldspar.Array.Vector
import Feldspar.Array.Buffered

import Data.Bits (Bits)
import Data.Complex (Complex)

import Prelude hiding ((==), (/=), (>), (<=), length, div, reverse, sum)

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

inc :: Software ()
inc = do
  len :: SExp Length <- fget stdin
  ix  :: SExp Index  <- fget stdin
  arr :: Arr (SExp Word32) <- newArr len
--  assert (ix <= length arr) "ix out of bounds"
  val <- getArr arr ix
  setArr arr ix (val + 1)

copy :: Software ()
copy = do
  arr1 :: Arr (SExp Word32) <- newArr 10
  arr2 :: Arr (SExp Word32) <- unsafeFreezeArr arr1 >>= unsafeThawArr
  --
  setArr arr1 0 0
  val <- getArr arr1 0
  setArr arr2 0 val

inplace :: Software ()
inplace = do
  st  :: Store Software (SExp Word32) <- newInPlaceStore 10
  arr :: Manifest Software (SExp Word32) <- store st $ (1...10)
  brr <- store st $ reverse arr
  val <- shareM $ sum brr
  return ()
 where
  reverse :: Manifest Software (SExp Word32) -> Push Software (SExp Word32)
  reverse = pairwise (\ix -> (ix, 10-ix-1))

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

-- A super-simple verification example.
count :: Software ()
count = do
  printf "Enter a number: "
  n :: SExp Word32 <- fget stdin

  let total = iter n 0 (\i n -> hint (n == i) $ i + 1)
  total <- initRef total >>= unsafeFreezeRef
  assert (total == n) "Count is wrong"
  printf "The count is %d\n" total

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

rev :: Software ()
rev = do
  n <- fget stdin
  loc :: IArr (SExp Word32) <- newArr n >>= unsafeFreezeArr
  cpy :: Arr  (SExp Word32) <- newArr n
  assert (n > 0) "neg"
  for 0 1 (n-1) $ \i -> do
    setArr cpy i (loc ! (n-i-1))

rev_inplace :: Software ()
rev_inplace = do
    n <- fget stdin
    loc :: Arr (SExp Word32) <- newArr n
    vec <- unsafeFreezeArr loc >>= unsafeThawArr
    for 0 1 ((n `div` 2 :: SExp Word32)) $ \i -> do
      x <- getArr vec i
      y <- getArr vec (n-i-1)
      setArr loc i y
      setArr loc (n-i-1) x

rev_amazing :: Software ()
rev_amazing = do
    n <- fget stdin
    iarr :: IArr (SExp Word32) <- newArr n >>= unsafeFreezeArr
    arr <- unsafeThawArr iarr
    result <- manifestArr arr (pairwise @Software (\i -> (i, n-i-1)) (reverse iarr))
    return ()

------------------------------------------------------------
{-
test_scProd1 = do
    n <- fget stdin
    printf "result: %.3f\n" $
      (scProd (fmap i2n (0 ... n-1)) (fmap i2n (2 ... n+1)) :: Data Double)

test_scProd2 = do
    n  <- fget stdin
    v1 <- manifestFresh $ fmap i2n (0 ... n-1)
    v2 <- manifestFresh $ fmap i2n (2 ... n+1)
    printf "result: %.3f\n" (scProd v1 v2 :: Data Double)

map_inplace :: Run ()
map_inplace = do
    n   <- fget stdin
    loc <- newArr n
    vec <- manifest loc (0 ... n-1)
    manifestStore loc $ map (+1) vec
    vec <- unsafeFreezeArr loc
    printf "result: %d\n" $ sum vec

map2_inplace :: Run ()
map2_inplace = do
    n   <- fget stdin
    assert (n < maxBound) "oops"
    loc :: Arr (Data Word32) <- newArr (n+1)
    vec <- unsafeFreezeArr loc
    for (0, 1, Excl (n :: Data Word32)) $ \i -> do
      setArr loc i (arrIx vec i+1)

tail_inplace :: Run ()
tail_inplace = do
    n <- fget stdin
    loc :: Arr (Data Word32) <- newArr n
    vec <- unsafeFreezeArr loc
    let when cond x = iff cond x (return ())
    when (n > 0) $
      for (0, 1, Excl (n-1)) $ \i -> do
        setArr loc i (arrIx vec (i+1)+1)

filter_inplace :: Run ()
filter_inplace = do
    n <- fget stdin
    loc :: Arr (Data Word32) <- newArr n
    vec <- unsafeFreezeArr loc
    ref <- initRef 0
    let when cond x = iff cond x (return ())
    for (0, 1, Excl n) $ \i -> do
      let x = arrIx vec i
      when (x > 5) $ do
        j <- unsafeFreezeRef ref
        hint (j <= i)
        setArr loc j x
        setRef ref (j+1)

rev_inplace :: Software ()
rev_inplace = do
    n <- fget stdin
    loc :: Arr (Data Word32) <- newArr n
    vec <- unsafeFreezeArr loc >>= unsafeThawArr
    for (0, 1, Excl (n `div` 2 :: Data Word32)) $ \i -> do
      x <- getArr vec i
      y <- getArr vec (n-i-1)
      setArr loc i y
      setArr loc (n-i-1) x
-}
--------------------------------------------------------------------------------

max_stars_repo_name: markus-git/co-feldspar

max_issues_repo_name: markus-git/co-feldspar

max_forks_repo_name: markus-git/co-feldspar


text:
module Data.Mat.MemParser where

import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Complex
import Foreign

import Data.Mat.Raw

-- | A 'MemParser a b' is a parser that for an array of 'a's to a Haskell structure
-- of 'b's. It maintains an initial pointer to an 'a' and an integer offset.
type MemParser a = ReaderT (Ptr a) (StateT Int IO)

-- | A storable type can be parsed directly.
storable :: Storable a => MemParser a a
storable = do
  offset <- get
  p <- ask
  x <- liftIO (peekElemOff p offset)
  put (offset + 1)
  return x

-- | Parses an array of the given dimension. Takes a parser for the elements.
array :: Int -> MemParser a b -> MemParser a [b]
array n pe = replicateM n pe

-- | Parses a complex value of the given element type.
complex :: MemParser a b -> MemParser (CMatComplexSplit a) (Complex b)
complex pe = do
  ptr <- ask
  liftIO $ do
    c   <- peek ptr
    xRe <- runMemParser pe (re c)
    xIm <- runMemParser pe (im c)
    return $ xRe :+ xIm

-- | Parses nothing.
nothing :: MemParser a ()
nothing = return ()

-- | Runs a 'MemParser' by taking a pointer to the initial element.
runMemParser :: MemParser a b -> Ptr a -> IO b
runMemParser mp p = evalStateT (runReaderT mp p) 0

max_stars_repo_name: glutamate/matio

max_issues_repo_name: glutamate/matio

max_forks_repo_name: glutamate/matio


text:
module GenericLexer where

import Data.List
import Data.Ord
import Data.Char (isSpace, digitToInt)
import Data.Complex

import Text.ParserCombinators.Parsec ((<|>))

import qualified Text.ParserCombinators.Parsec as P
import qualified Text.Parsec.String as PS

import qualified Text.Parsec.Token as Tok

import Text.Parsec.Language (emptyDef)

import TokenParser

lexer = makeTokenParser style
  where
    style = emptyDef {
      Tok.commentLine = "//"
    , Tok.commentStart = "/*"
    , Tok.commentEnd = "*/"
    , Tok.nestedComments = False
    , Tok.identStart = letter
    , Tok.identLetter = letter <|> unicodeDigit
    , Tok.reservedOpNames = operators
    , Tok.reservedNames = keywords
    , Tok.caseSensitive = True
    }

unicodeLetter = P.letter

unicodeDigit = P.digit

letter = unicodeLetter <|> P.char '_'

keywords = [
            "break",        "default",      "func",         "interface",    "select",
            "case",         "defer",        "go",           "map",          "struct",
            "chan",         "else",         "goto",         "package",      "switch",
            "const",        "fallthrough",  "if",           "range",        "type",
            "continue",     "for",          "import",       "return",       "var",
            "extern"]

operators = [
             "+",    "&",     "+=",    "&=",     "&&",    "==",    "!=",    "(",    ")",
             "-",    "|",     "-=",    "|=",     "||",    "<",     "<=",    "[",    "]",
             "*",    "^",     "*=",    "^=",     "<-",    ">",     ">=",    "{",    "}",
             "/",    "<<",    "/=",    "<<=",    "++",    "=",     ":=",    ",",    ";",
             "%",    ">>",    "%=",    ">>=",    "--",    "!",     "...",   ".",    ":",
                     "&^",             "&^="]

identifier = Tok.identifier
keyword = Tok.reserved
operator = Tok.reservedOp
integer = Tok.integer
float = Tok.float
char = Tok.charLiteral
rune = char
string = Tok.stringLiteral

imaginary l = a <|> b
  where
    a = P.try $ do value <- integer l
                   P.char 'i'
                   return $ 0 :+ (fromInteger value)
    b = P.try $ do value <- float l
                   P.char 'i'
                   return $ 0 :+ value

parens = Tok.parens
brackets = Tok.brackets
braces = Tok.braces
commaSep = Tok.commaSep
semiSep = Tok.semiSep

semi l = operator l ";"

--anyKeyword :: PS.Parser String
anyKeyword l = P.choice $ map (keywordToken l) keywords

keywordToken l name = keyword l name >> return name

--anyOperator :: PS.Parser String
anyOperator l = P.choice $ map (operatorToken l) operators

operatorToken l name = operator l name >> return name

--anyLiteral :: PS.Parser String
anyLiteral l
    = P.try (floatToken l)
  <|> P.try (imaginaryToken l)
  <|> P.try (integerToken l)
  <|> P.try (runeToken l)
  <|> P.try (stringToken l)

floatToken l = float l >>= return . show
imaginaryToken l = imaginary l >>= return . show
integerToken l = integer l >>= return . show
runeToken l = rune l >>= return . (flip (:)) []
stringToken l = string l >>= return . show

nonNewlineWhitespace :: PS.Parser String
nonNewlineWhitespace = P.oneOf " \t" >>= return . (flip (:)) []

whitespace = Tok.whiteSpace

nonNullWhitespace :: PS.Parser String
nonNullWhitespace = P.many1 $ P.oneOf " \t\n"

--whitespaceToken :: PS.Parser String
whitespaceToken l = whitespace l >> return " "

newline :: PS.Parser String
newline = P.newline >> return "\n"

-- parse
parse parser contents = P.parse parser "$STDIN" contents

max_stars_repo_name: waterlink/hgp

max_issues_repo_name: waterlink/hgp

max_forks_repo_name: waterlink/hgp


text:
module Wavefront.Converter where

import qualified Types as T
import Wavefront.Types
import Numeric.Vector
import VecUtil

face2Tri :: [Vertex_] -> [TexCoord_] -> [Normal_] -> Face_ -> T.Tri
face2Tri vs tcs ns (Face_ p1 tc1 n1 p2 tc2 n2 p3 tc3 n3) =
  let (t1, b1) = tangentBitangent $ normalToVec $ ns !! n1
      (t2, b2) = tangentBitangent $ normalToVec $ ns !! n2
      (t3, b3) = tangentBitangent $ normalToVec $ ns !! n3
      v1 = T.Vertex (vertexToVec $ vs !! p1) (vec3 1 1 1) (texCoordToVec $ tcs !! tc1) (normalToVec $ ns !! n1) t1 b1
      v2 = T.Vertex (vertexToVec $ vs !! p2) (vec3 1 1 1) (texCoordToVec $ tcs !! tc2) (normalToVec $ ns !! n2) t2 b2
      v3 = T.Vertex (vertexToVec $ vs !! p3) (vec3 1 1 1) (texCoordToVec $ tcs !! tc3) (normalToVec $ ns !! n3) t3 b3
  in  T.Tri v1 v2 v3

obj2Mesh :: [WavefrontLine] -> [T.Tri]
obj2Mesh ls = let verts = map vertexFromLine $ filter isVertex ls
                  texCoords = map texCoordFromLine $ filter isTexCoord ls
                  normals = map normalFromLine $ filter isNormal ls
                  faces = map faceFromLine $ filter isFace ls
              in  map (face2Tri verts texCoords normals) faces


text:
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import qualified Data.List                    as List
import qualified Data.Text                    as T
import qualified Data.Vector.Storable         as V
import qualified Data.Vinyl                   as V
import qualified Frames                       as F

import           Numeric.LinearAlgebra        (( #> ), (<#), (<.>), (<\>))
import qualified Numeric.LinearAlgebra        as LA
import           Numeric.LinearAlgebra.Data   (Matrix, R, Vector)
import qualified Numeric.LinearAlgebra.Data   as LA

import           Control.Applicative
import           Control.Monad
import           EasyTest

import qualified Math.Regression.LeastSquares as LS
import qualified System.PipesLogger           as SL

main = runOnly "all" suite

suite :: Test ()
suite = tests
  [
    scope "all.Regression" $ do
      testOLS
      testTLS
  ]

logged = SL.runLoggerIO SL.logAll
-- regression tests

-- build some data for testing
-- uniformly distributed measurements, normally distributed noise.  Separate noise amplitudes for xs and ys
-- also allow building heteroscedastic data
buildRegressable :: [Double] -> Double -> LA.Vector R -> Double -> IO (LA.Vector R, LA.Matrix R)
buildRegressable variances noiseObs coeffs noiseMeas = do
  -- generate random measurements
  let d = LA.size coeffs
      nObs = List.length variances
  xs0 <- LA.rand nObs d
  xNoise <- LA.randn nObs d
  let xs = xs0 + LA.scale noiseMeas xNoise
  let ys0 = xs LA.<> LA.asColumn coeffs
  yNoise <- fmap (List.head . LA.toColumns) (LA.randn nObs 1)
  let ys = ys0 + LA.asColumn (LA.scale noiseObs (V.zipWith (*) yNoise (LA.cmap sqrt (LA.fromList variances))))
  return (List.head (LA.toColumns ys), xs)

unweighted :: Int -> [Double] = flip List.replicate 1

showText = T.pack . show

testOLS :: Test ()
testOLS =  scope "OLS" $ do
  let errR2 res = let r2 = LS.rSquared res in (r2 <= 1 && r2 > 0.8)
      coeffs :: LA.Vector R = LA.fromList [1.0, 2.2, 0.3]
  scope "No noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0 coeffs 0
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (0 noise)\n" <> T.pack (show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.01,0) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (1% noise in ys)\n" <> T.pack (show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.1,0) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (10% noise in ys)\n" <> T.pack (show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.01,0.01) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0.01
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (1% noise in ys, 1% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.1,0.1) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0.1
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (10% noise in ys, 10% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.3,0.3) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.3 coeffs 0.3
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (30% noise in ys, 30% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result

testTLS :: Test ()
testTLS = scope "TLS" $ do
  let errR2 res = let r2 = LS.rSquared res in (r2 <= 1 && r2 > 0.8)
      coeffs :: LA.Vector R = LA.fromList [1.0, 2.2, 0.3]
  scope "No noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0 coeffs 0
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (0 noise)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "0.01 Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (1% noise in ys)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "0.1 Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (10% noise in ys)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.01,0.01) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0.01
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (1% noise in ys, 1% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.1,0.1) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0.1
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (10% noise in ys, 10% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.3,0.3) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.3 coeffs 0.3
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (30% noise in ys, 30% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result

max_stars_repo_name: teto/Frames-utils

max_issues_repo_name: teto/Frames-utils

max_forks_repo_name: teto/Frames-utils


text:
module HtmlReport (htmlReport) where

import Data.Foldable (traverse_)
import Data.Semigroup((<>))
import Data.ByteString.Lazy (ByteString)
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes (src)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)

import QuoteData
import StatReport (showStatEntryValue)
import Statistics
import Fmt

htmlReport :: (Functor t, Foldable t) => String -> t QuoteData -> StatInfo -> [FilePath] -> ByteString
htmlReport title quotes si images = renderHtml $
  docTypeHtml $ do
    H.head $ do
      H.title $ string title
      H.style style
    body $ do
      renderDiagram images
      rendetStatInfo si
      renderData quotes
  where
    style = "table {border-collapse: collapse}" <> "td, th {border: 1px solid black; padding: 3px}"

    renderDiagram [] = pure ()
    renderDiagram images = do
      h1 "Diagrams"
      traverse_ ((img!) . src . toValue) images

    rendetStatInfo [] = pure ()
    rendetStatInfo si@((_, ses):_) = do
      h1 "Statistic Report"
      table $ do
        thead . tr . traverse_ th $ "Quoted Field" : [text . fmt . build . stat $ s | s <- ses]
        tbody . traverse_ statData2TR $ si

    statData2TR (qf, entries) = tr $ do
      td . string $ show qf
      traverse_ (td . string . showStatEntryValue) entries

    renderData quotes = do
      h1 "Stock Quotes Data"
      table $ do
        thead . tr . traverse_ th $ ["Day", "Close", "Volume", "Open", "High", "Low"]
        tbody . traverse_ quoteData2TR $ quotes

    quoteData2TR QuoteData {..} = tr $ do
      td. string $ show day
      traverse_ (td . string . show) [close, volume, open, high, low]


text:
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} -- required for HMatrix
-- | Albemarle, natural language processing for Haskell
module NLP.Albemarle (
  SparseMatrix(..),
  SparseVector(..),
  DenseVector(..)
) where
import ClassyPrelude hiding (Vector)
import Numeric.LinearAlgebra
import qualified Data.Vector.Unboxed as Vec

-- | Vector of sorted (word ID, count)
data SparseVector = SparseVector Int [(Int, Double)]
  deriving (Show, Eq)
data SparseMatrix = SparseMatrix Int [SparseVector]
  deriving (Show, Eq)
type DenseVector = Vector Double

instance (Container Vector t, Eq t, Num (Vector t), Product t) => Semigroup (Matrix t) where
  (<>) = mappend

max_stars_repo_name: SeanTater/albemarle

max_issues_repo_name: SeanTater/albemarle

max_forks_repo_name: SeanTater/albemarle


text:
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}

module School.Unit.UnitGradient
( UnitGradient(..)
, isGradientFail
) where

import Numeric.LinearAlgebra (Container, Matrix, Vector)

data UnitGradient a =
   BatchGradient (Matrix a)
 | GradientFail String deriving (Show)

instance (Container Vector a, Num a, Eq a) => Eq (UnitGradient a) where
  (BatchGradient g1) == (BatchGradient g2) =
    g1 == g2
  (GradientFail _) == (GradientFail _) = True
  _ == _ = False

isGradientFail :: UnitGradient a -> Bool
isGradientFail (GradientFail _) = True
isGradientFail _ = False

max_stars_repo_name: jfulseca/School

max_issues_repo_name: jfulseca/School

max_forks_repo_name: jfulseca/School


text:
{-# LANGUAGE DeriveDataTypeable #-}

module Text.Namelist.Types where

import Data.Complex
import Data.CaseInsensitive (CI)
import Data.Data(Data, Typeable)

data Index
    = Index Int
    | Range (Maybe Int) (Maybe Int) (Maybe Int)
    deriving (Show, Read, Data, Typeable, Eq)

data Key
    = Key     (CI String)
    | Indexed (CI String) [Index]
    | Sub     (CI String) Key
    deriving (Show, Read, Data, Typeable, Eq)

data Value
    = Integer Int
    | Real Double
    | Complex (Complex Double)
    | Logical Bool
    | String String
    | Array [Value]
    | Int :* Value
    | Null
    deriving (Show, Read, Data, Typeable, Eq)

data Pair = Key := Value
    deriving (Show, Read, Data, Typeable, Eq)

data Group = Group (CI String) [Pair]
    deriving (Show, Read, Data, Typeable, Eq)

max_stars_repo_name: philopon/namelist-hs

max_issues_repo_name: philopon/namelist-hs

max_forks_repo_name: philopon/namelist-hs