Ex.hs

{-# LANGUAGE Arrows                #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}

module Ex where

import           Control.Applicative
import           Control.Arrow
import           Control.Lens
import           Data.Profunctor.Product
import           Data.Profunctor.Product.Default
import           Data.Profunctor.Product.TH      (makeAdaptorAndInstance)
import           Data.Time
import qualified Karamaan.Opaleye.Operators2     as Op2
import qualified Karamaan.Opaleye.Predicates     as Pred
import           Karamaan.Opaleye.QueryArr
import           Karamaan.Opaleye.SQL
import           Karamaan.Opaleye.Table
import           Karamaan.Opaleye.Unpackspec
import           Karamaan.Opaleye.Wire

-- Create Table "user"
--   ( "project" integer not null
--   , "number" integer not null
--   , Constraint "user_pk" Primary Key ("project", "number")
--   );

-- Create Table "observation"
--   ( "project" integer not null
--   , "number" integer not null
--   , "datetime" date time not null
--   , "value" integer not null
--   , Constraint "observation_pk"
--     Primary Key ("project", "number", "datetime")
--   , Constraint "observation_user_fk"
--     Foreign Key ("project", "number")
--     References user("project", "number")
--   );

class HasUser f a where
  _projectF :: Lens' a (f Int)
  _numberF  :: Lens' a (f Int)

data User' p n = User p n deriving ( Eq, Show )
type User = User' Int Int
type UserWire = User' (Wire Int) (Wire Int)

-- instance HasUser Identity User where
--   _project inj (User p n) = (\p' -> User p' n) <$> inj p
--   _number  inj (User p n) = (\n' -> User p n') <$> inj n

instance HasUser Wire UserWire where
  _projectF inj (User p n) = (\p' -> User p' n) <$> inj p
  _numberF  inj (User p n) = (\n' -> User p n') <$> inj n

makeAdaptorAndInstance "pUser" ''User'

user :: Query UserWire
user = makeTableDef (User "study" "site") "user"



data Observation' p n d v = Observation p n d v deriving ( Eq, Show )
type Observation = Observation' Int Int UTCTime Int
type ObservationWire = Observation' (Wire Int) (Wire Int) (Wire UTCTime) (Wire Int)

instance HasUser Wire ObservationWire where
  _projectF inj (Observation p n d v) = (\p' -> Observation p' n d v) <$> inj p
  _numberF  inj (Observation p n d v) = (\n' -> Observation p n' d v) <$> inj n

makeAdaptorAndInstance "pObservation" ''Observation'

observation :: Query ObservationWire
observation = makeTableDef
              (Observation "project" "number" "datetime" "value")
              "observation"




userN :: User -> Query UserWire
userN (User p n) = proc () -> do
  u@(User up un) <- user           -< ()
  wp             <- Op2.constant p -< ()
  wn             <- Op2.constant n -< ()
  Pred.restrict <<< Op2.eq -< (wp, up)
  Pred.restrict <<< Op2.eq -< (wn, un)
  returnA -< u

observationOfUser :: QueryArr UserWire ObservationWire
observationOfUser = proc (User up un) -> do
  o@(Observation obp obn _ _) <- observation -< ()
  Pred.restrict <<< Op2.eq -< (up, obp)
  Pred.restrict <<< Op2.eq -< (un, obn)
  returnA -< o

valuesOfUser :: QueryArr UserWire (Wire Int, Wire UTCTime)
valuesOfUser = observationOfUser >>> proc (Observation _ _ d v) -> do
  returnA -< (v, d)

sh :: Default (PPOfContravariant Unpackspec) a a => Query a -> IO ()
sh = putStrLn . showSqlForPostgresDefault