Enable chart responsiveness

Enable chart responsiveness

module Main where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.JSON
import ChartJs
import WebSocket
import qualified Control.Monad.Eff.Console as C
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Exception
import Control.Monad.Trans (lift)
import Control.Monad.Maybe.Trans
import qualified Control.Monad.Eff.JQuery as J
import Data.Either (Either (Left, Right))
import DOM
import Graphics.Canvas
import Optic.Core

main :: forall eff. Eff (ws :: WS, console :: C.CONSOLE, dom :: DOM, canvas::Canvas, err :: EXCEPTION | eff) Unit
main = do
  C.log "START"
  runWebSocket $ do
    result <- withWebSocket config handlers
    case result of
         Right _ -> output "DONE"
         Left err -> output err

config :: WebSocketConfig
config =
  { uri: "ws://127.0.0.1:9001"
  , protocols: []
  }

handlers :: forall eff. WebSocketHandler (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff)
handlers s = (defaultHandlers s)
  { onOpen = onOpenHandler
  , onMessage = onMessageHandler
  }

onOpenHandler :: forall eff. WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onOpenHandler = C.log "OPEN"

onMessageHandler :: forall eff. String -> WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onMessageHandler msg = do
  case (decode msg :: Maybe Cpu) of
    Just c -> do
      initGraph "bar" $ initBar c
      C.log $ "Successfully parsed" ++ show c
    Nothing -> C.log "Failed to parse message"
  return unit

output :: forall eff. String -> WebSocket (console :: C.CONSOLE | eff) Unit
output = lift <<< C.log

initGraph
  :: forall eff
   . String
  -> (Chart -> Eff( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) ChartType)
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) Unit
initGraph name f = void $ do
  cMay  <- getCanvasElementById cId
  c     <- maybe (die $ "Could not find canvas: " <> cId) pure cMay
  ctx   <- getContext2D c
  chart <- newChart ctx
  ct    <- f chart
  lt    <- generateLegend ct
  leg   <- J.select $ "#" <> lId
  J.appendText lt leg
  where
    cId = name <> "-canvas"
    lId = name <> "-legend"

initBar
  :: forall eff
   . Cpu
  -> Chart
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas:: Canvas | eff ) ChartType
initBar (Cpu {cpuData = cpuData}) c =
  barChart c barData (responsiveChartConfig hmonBarChartCfg)
  where
    barData = {
      labels : ["user","nice","system","idle","iowait","irq","softirq"],
      datasets : [
        { fillColor : "rgba(2,136,209,0.75)"
        , strokeColor : "rgba(220,220,220,0.8)"
        , highlightFill: "rgba(255,82,82,0.75)"
        , highlightStroke: "rgba(220,220,220,1)"
        , data : cpuData
        }
        ]}

hmonChartCfg :: ChartConfig
hmonChartCfg = set animation false defGlobalChartConfig

hmonBarChartCfg :: BarChartConfig
hmonBarChartCfg = responsiveChartConfig $ set global hmonChartCfg $ set legendTemplate "" defBarChartConfig -- Pretty way for this ?

animation :: forall a b r. Lens { animation :: a | r } { animation :: b | r } a b
animation = lens _.animation (_ { animation = _ })

global :: forall a b r. Lens { global :: a | r } { global :: b | r } a b
global = lens _.global (_ { global = _ })

legendTemplate :: forall a b r. Lens { legendTemplate :: a | r } { legendTemplate :: b | r } a b
legendTemplate = lens _.legendTemplate (_ { legendTemplate = _ })

die :: forall eff a. String -> Eff( err:: EXCEPTION | eff ) a
die = error >>> throwException

data Cpu = Cpu {
              cpuData :: Array Number
           }

instance showCpu :: Show Cpu where
  show (Cpu cData) = "CPU: "

instance cpuFromJSON :: FromJSON Cpu where
  parseJSON (JObject o) = do
    d <- o .: "cpu"
    return $ Cpu {cpuData: d}

module Main where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.JSON
import ChartJs
import WebSocket
import qualified Control.Monad.Eff.Console as C
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Exception
import Control.Monad.Trans (lift)
import Control.Monad.Maybe.Trans
import qualified Control.Monad.Eff.JQuery as J
import Data.Either (Either (Left, Right))
import DOM
import Graphics.Canvas
import Optic.Core

main :: forall eff. Eff (ws :: WS, console :: C.CONSOLE, dom :: DOM, canvas::Canvas, err :: EXCEPTION | eff) Unit
main = do
  C.log "START"
  runWebSocket $ do
    result <- withWebSocket config handlers
    case result of
         Right _ -> output "DONE"
         Left err -> output err

config :: WebSocketConfig
config =
  { uri: "ws://127.0.0.1:9001"
  , protocols: []
  }

handlers :: forall eff. WebSocketHandler (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff)
handlers s = (defaultHandlers s)
  { onOpen = onOpenHandler
  , onMessage = onMessageHandler
  }

onOpenHandler :: forall eff. WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onOpenHandler = C.log "OPEN"

onMessageHandler :: forall eff. String -> WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onMessageHandler msg = do
  case (decode msg :: Maybe Cpu) of
    Just c -> do
      initGraph "bar" $ initBar c
      C.log $ "Successfully parsed" ++ show c
    Nothing -> C.log "Failed to parse message"
  return unit

output :: forall eff. String -> WebSocket (console :: C.CONSOLE | eff) Unit
output = lift <<< C.log

initGraph
  :: forall eff
   . String
  -> (Chart -> Eff( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) ChartType)
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) Unit
initGraph name f = void $ do
  cMay  <- getCanvasElementById cId
  c     <- maybe (die $ "Could not find canvas: " <> cId) pure cMay
  ctx   <- getContext2D c
  chart <- newChart ctx
  ct    <- f chart
  lt    <- generateLegend ct
  leg   <- J.select $ "#" <> lId
  J.appendText lt leg
  where
    cId = name <> "-canvas"
    lId = name <> "-legend"

initBar
  :: forall eff
   . Cpu
  -> Chart
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas:: Canvas | eff ) ChartType
initBar (Cpu {cpuData = cpuData}) c =
  barChart c barData (responsiveChartConfig hmonBarChartCfg)
  where
    barData = {
      labels : ["user","nice","system","idle","iowait","irq","softirq"],
      datasets : [
        { fillColor : "rgba(2,136,209,0.75)"
        , strokeColor : "rgba(220,220,220,0.8)"
        , highlightFill: "rgba(255,82,82,0.75)"
        , highlightStroke: "rgba(220,220,220,1)"
        , data : cpuData
        }
        ]}

hmonChartCfg :: ChartConfig
hmonChartCfg = set animation false defGlobalChartConfig

hmonBarChartCfg :: BarChartConfig
hmonBarChartCfg = set global hmonChartCfg $ set legendTemplate "" defBarChartConfig -- Pretty way for this ?

animation :: forall a b r. Lens { animation :: a | r } { animation :: b | r } a b
animation = lens _.animation (_ { animation = _ })

global :: forall a b r. Lens { global :: a | r } { global :: b | r } a b
global = lens _.global (_ { global = _ })

legendTemplate :: forall a b r. Lens { legendTemplate :: a | r } { legendTemplate :: b | r } a b
legendTemplate = lens _.legendTemplate (_ { legendTemplate = _ })

die :: forall eff a. String -> Eff( err:: EXCEPTION | eff ) a
die = error >>> throwException

data Cpu = Cpu {
              cpuData :: Array Number
           }

instance showCpu :: Show Cpu where
  show (Cpu cData) = "CPU: "

instance cpuFromJSON :: FromJSON Cpu where
  parseJSON (JObject o) = do
    d <- o .: "cpu"
    return $ Cpu {cpuData: d}


WIP [ci skip]

WIP [ci skip]

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b o m =
    Atom      m  a
  | List      m (List (Tree a b o m))
  | NTuple    m (List (Tree a b o m))
  | Binary    m o (Tree a b o m) (Tree a b o m)
  | Unary     m o (Tree a b o m)
  | SectL     m (Tree a b o m) o
  | SectR     m o (Tree a b o m)
  | PrefixOp  m o
  | IfExpr    m (Tree a b o m) (Tree a b o m) (Tree a b o m)
  | ArithmSeq m (Tree a b o m) (Maybe (Tree a b o m)) (Maybe (Tree a b o m))
  | LetExpr   m (List (Tuple b (Tree a b o m))) (Tree a b o m)
  | Lambda    m (List b) (Tree a b o m)
  | App       m (Tree a b o m) (List (Tree a b o m))
  | ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))

data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

foldTree :: forall a b o m u v.
                      (m -> a -> u)
                   -> (m -> List u -> u)
                   -> (m -> List u -> u)
                   -> (m -> o -> u -> u -> u)
                   -> (m -> o -> u -> u)
                   -> (m -> u -> o -> u)
                   -> (m -> o -> u -> u)
                   -> (m -> o -> u)
                   -> (m -> u -> u -> u -> u)
                   -> (m -> u -> Maybe u -> Maybe u -> u)
                   -> (m -> List (Tuple b u) -> u -> u)
                   -> (m -> List b -> u -> u)
                   -> (m -> u -> List u -> u)
                   -> (m -> u -> List v -> u)
                   -> (m -> b -> u -> v)
                   -> (m -> b -> u -> v)
                   -> (m -> u -> v)
                   -> Tree a b o m -> u
foldTree atom list ntuple binary unary sectl sectr prefixop ifexpr arithmseq letexpr lambda app listcomp gen let' guard = go
  where
    go (Atom m a)               = atom m a
    go (List m us)              = list m (go <$> us)
    go (NTuple m us)            = ntuple m (go <$> us)
    go (Binary m o u1 u2)       = binary m o (go u1) (go u2)
    go (Unary m o u)            = unary m o (go u)
    go (SectL m u o)            = sectl m (go u) o
    go (SectR m o u)            = sectr m o (go u)
    go (PrefixOp m o)           = prefixop m o
    go (IfExpr m u1 u2 u3)      = ifexpr m (go u1) (go u2) (go u3)
    go (ArithmSeq m u1 mu2 mu3) = arithmseq m (go u1) (go <$> mu2) (go <$> mu3)
    go (LetExpr m tus u)        = letexpr m (rmap go <$> tus) (go u)
    go (Lambda m bs u)          = lambda m bs (go u)
    go (App m u us)             = app m (go u) (go <$> us)
    go (ListComp m u qs)        = listcomp m (go u) (qual <$> qs)
      where
        qual :: QualTree b (Tree a b o m) m -> v
        qual (Gen m b u) = gen m b (go u)
        qual (Let m b u) = let' m b (go u)
        qual (Guard m u) = guard m (go u)

idFoldTree :: forall a b o m. Tree a b o m -> Tree a b o m
idFoldTree = foldTree Atom List NTuple Binary Unary SectL SectR PrefixOp IfExpr ArithmSeq LetExpr Lambda App ListComp Gen Let Guard

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorTree :: Functor (Tree a b c) where
  map f = foldTree
          (Atom <<< f)
          (List <<< f)
          (NTuple <<< f)
          (Binary <<< f)
          (Unary <<< f)
          (SectL <<< f)
          (SectR <<< f)
          (PrefixOp <<< f)
          (IfExpr <<< f)
          (ArithmSeq <<< f)
          (LetExpr <<< f)
          (Lambda <<< f)
          (App <<< f)
          (ListComp <<< f)
          (Gen <<< f)
          (Let <<< f)
          (Guard <<< f)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

type TypeTree = Tree MType (Binding MType) (Tuple Op MType) MType

type ExprQualTree = QualTree (Binding Unit) Expr Unit

type TypeQual  = QualTree (Binding Type) TypeTree Type

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

-- derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding m = Lit       m Atom
               | ConsLit   m (Binding m) (Binding m)
               | ListLit   m (List (Binding m))
               | NTupleLit m (List (Binding m))

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List (Binding Unit)) Expr

derive instance eqDefintion :: Eq Definition

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

-- instance showQual :: (Show b, Show e) => Show (Qual b e) where
--   show q = case q of
--     Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
--     Let b e -> "Let (" <> show b <> " " <> show e <> ")"
--     Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: (Show a) => Show (Binding a) where
  show binding = case binding of
    Lit m atom     -> "(Lit " <> show m <> " " <> show atom <> ")"
    ConsLit m b bs -> "(ConsLit " <> show m <> " " <> show b <> ") (" <> show bs <> ")"
    ListLit m bs   -> "(ListLit " <> show m <> " " <> show bs <> ")"
    NTupleLit m ls -> "(NTupleLit " <> show m <> " " show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b o m =
    Atom      m  a
  | List      m (List (Tree a b o m))
  | NTuple    m (List (Tree a b o m))
  | Binary    m o (Tree a b o m) (Tree a b o m)
  | Unary     m o (Tree a b o m)
  | SectL     m (Tree a b o m) o
  | SectR     m o (Tree a b o m)
  | PrefixOp  m o
  | IfExpr    m (Tree a b o m) (Tree a b o m) (Tree a b o m)
  | ArithmSeq m (Tree a b o m) (Maybe (Tree a b o m)) (Maybe (Tree a b o m))
  | LetExpr   m (List (Tuple b (Tree a b o m))) (Tree a b o m)
  | Lambda    m (List b) (Tree a b o m)
  | App       m (Tree a b o m) (List (Tree a b o m))
  | ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))

data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

foldTree :: forall a b o m u v.
                      (m -> a -> u)
                   -> (m -> List u -> u)
                   -> (m -> List u -> u)
                   -> (m -> o -> u -> u -> u)
                   -> (m -> o -> u -> u)
                   -> (m -> u -> o -> u)
                   -> (m -> o -> u -> u)
                   -> (m -> o -> u)
                   -> (m -> u -> u -> u -> u)
                   -> (m -> u -> Maybe u -> Maybe u -> u)
                   -> (m -> List (Tuple b u) -> u -> u)
                   -> (m -> List b -> u -> u)
                   -> (m -> u -> List u -> u)
                   -> (m -> u -> List v -> u)
                   -> (m -> b -> u -> v)
                   -> (m -> b -> u -> v)
                   -> (m -> u -> v)
                   -> Tree a b o m -> u
foldTree atom list ntuple binary unary sectl sectr prefixop ifexpr arithmseq letexpr lambda app listcomp gen let' guard = go
  where
    go (Atom m a)               = atom m a
    go (List m us)              = list m (go <$> us)
    go (NTuple m us)            = ntuple m (go <$> us)
    go (Binary m o u1 u2)       = binary m o (go u1) (go u2)
    go (Unary m o u)            = unary m o (go u)
    go (SectL m u o)            = sectl m (go u) o
    go (SectR m o u)            = sectr m o (go u)
    go (PrefixOp m o)           = prefixop m o
    go (IfExpr m u1 u2 u3)      = ifexpr m (go u1) (go u2) (go u3)
    go (ArithmSeq m u1 mu2 mu3) = arithmseq m (go u1) (go <$> mu2) (go <$> mu3)
    go (LetExpr m tus u)        = letexpr m (rmap go <$> tus) (go u)
    go (Lambda m bs u)          = lambda m bs (go u)
    go (App m u us)             = app m (go u) (go <$> us)
    go (ListComp m u qs)        = listcomp m (go u) (qual <$> qs)
      where
        qual :: QualTree b (Tree a b o m) m -> v
        qual (Gen m b u) = gen m b (go u)
        qual (Let m b u) = let' m b (go u)
        qual (Guard m u) = guard m (go u)

idFoldTree :: forall a b o m. Tree a b o m -> Tree a b o m
idFoldTree = foldTree Atom List NTuple Binary Unary SectL SectR PrefixOp IfExpr ArithmSeq LetExpr Lambda App ListComp Gen Let Guard

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorTree :: Functor (Tree a b c) where
  map f = foldTree
          (Atom <<< f)
          (List <<< f)
          (NTuple <<< f)
          (Binary <<< f)
          (Unary <<< f)
          (SectL <<< f)
          (SectR <<< f)
          (PrefixOp <<< f)
          (IfExpr <<< f)
          (ArithmSeq <<< f)
          (LetExpr <<< f)
          (Lambda <<< f)
          (App <<< f)
          (ListComp <<< f)
          (Gen <<< f)
          (Let <<< f)
          (Guard <<< f)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

extractBindingType:: TypeBinding -> Type
extractBindingType (TLit t)         = t
extractBindingType (TConsLit _ _ t) = t
extractBindingType (TListLit _ t)   = t
extractBindingType (TNTupleLit _ t) = t

type Expr = Tree Atom Binding Op Unit

type TypeTree = Tree Unit TypeBinding Type Type

type IndexTree = Tree Unit IBinding Op Int

type ExprQualTree = QualTree Binding Expr Unit

type IndexQual = QualTree IBinding IndexTree Int

type TypeQual  = QualTree TypeBinding TypeTree Type

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
               | IConsLit IBinding IBinding  Int
               | IListLit (List IBinding)    Int
               | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

-- derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

derive instance eqDefintion :: Eq Definition

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

-- instance showQual :: (Show b, Show e) => Show (Qual b e) where
--   show q = case q of
--     Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
--     Let b e -> "Let (" <> show b <> " " <> show e <> ")"
--     Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

-- instance showTypeTree :: Show TypeTree where
--   show (TAtom t) = "(TAtom " <> show t <> ")"
--   show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
--   show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
--   show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
--   show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
--   show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
--   show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
--   show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
--   show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
--   show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
--   show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
--   show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

-- extractType:: TypeTree -> Type
-- extractType (TAtom t)            = t
-- extractType (TListTree _ t)      = t
-- extractType (TNTuple _ t)        = t
-- extractType (TBinary _ _ _ t)    = t
-- extractType (TUnary _ _ t)       = t
-- extractType (TSectL _ _ t)       = t
-- extractType (TSectR _ _ t)       = t
-- extractType (TPrefixOp t)        = t
-- extractType (TIfExpr _ _ _ t)    = t
-- extractType (TArithmSeq _ _ _ t) = t
-- extractType (TLetExpr _ _ t)     = t
-- extractType (TLambda _ _ t)      = t
-- extractType (TApp _ _ t)         = t
-- extractType (TListComp _ _ t)    = t

-- extractIndex :: IndexTree -> Int
-- extractIndex (IAtom i)            = i
-- extractIndex (IListTree _ i)      = i
-- extractIndex (INTuple _ i)        = i
-- extractIndex (IBinary _ _ _ i)    = i
-- extractIndex (IUnary _ _ i)       = i
-- extractIndex (ISectL _ _ i)       = i
-- extractIndex (ISectR _ _ i)       = i
-- extractIndex (IPrefixOp i)        = i
-- extractIndex (IIfExpr _ _ _ i)    = i
-- extractIndex (IArithmSeq _ _ _ i) = i
-- extractIndex (ILetExpr _ _ i)     = i
-- extractIndex (ILambda _ _ i)      = i
-- extractIndex (IApp _ _ i)         = i
-- extractIndex (IListComp _ _ i)    = i

-- extractBindingType:: TypeBinding -> Type
-- extractBindingType (TLit t)         = t
-- extractBindingType (TConsLit _ _ t) = t
-- extractBindingType (TListLit _ t)   = t
-- extractBindingType (TNTupleLit _ t) = t


clean up answerClicked

clean up answerClicked

module Main where

import Prelude hiding (div)

import Control.Bind ((=<<))
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.Eff.Console (CONSOLE(), log)
import Data.Array (filter, length, zip, (..), updateAt, snoc)
import Data.Array.Unsafe (unsafeIndex)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust)
import Data.Maybe.Unsafe (fromJust)
import Data.Foldable (foldMap)
import Data.Foreign
import Data.Foreign.Class (IsForeign, readProp, readJSON)
import Data.List (singleton)
import Data.String (joinWith)
import Data.Tuple (fst, snd, uncurry, Tuple(..))
import Network.HTTP.Affjax (AJAX(), get)
import Pux
import Pux.DOM.HTML.Elements (a, img, div, p, button, text)
import Pux.DOM.HTML.Attributes (href, src, onClick, send, className)
import Pux.Render.DOM
import qualified Signal.Channel as S

questionServiceUrl :: String
--questionServiceUrl = "http://localhost:8080/question"
questionServiceUrl = "http://54.174.99.38/question"

-- | We define a newtype for Question so we can create an IsForeign instance.
newtype Question = Question {
  questionText  :: String,
  answers       :: Array Answer,
  correctAnswer :: AnswerId,
  chosenAnswer  :: Maybe AnswerId  -- which answer the player clicked on
}

type QuestionId = Int
type Answer     = String
type AnswerId   = Int

-- | Deserializing from JSON is pretty straightforward, we just need to add an
-- | extra Nothing value for chosenAnswer.
instance questionIsForeign :: IsForeign Question where
  read value = do
    questionText  <- readProp "questionText"  value
    answers       <- readProp "answers"       value
    correctAnswer <- readProp "correctAnswer" value
    return $ Question {
      questionText : questionText,
      answers : answers,
      correctAnswer : correctAnswer,
      chosenAnswer : Nothing
    }

data Action =
    NewGame                          -- start a new game
  | ClickAnswer QuestionId AnswerId  -- click on an answer
  | QuestionReceived Question        -- receive an AJAX response with a question

type State = {
  score              :: Int,
  questions          :: Array Question,
  waitingForQuestion :: Boolean -- are we waiting for an AJAX call to return?
}

-- | Start out with no questions.
initialState :: State
initialState = { score: 0, questions: [], waitingForQuestion: true }

-- | When you click on questionId answerId, we need to update the score,
-- | set the chosenAnswer field for that question, and set the
-- | waitingForQuestion flag.
answerClicked :: QuestionId -> AnswerId -> State -> State
answerClicked questionId answerId state =
  { score : newScore, questions: newQuestions, waitingForQuestion: true }
  where
    q = case state.questions `unsafeIndex` questionId of Question q' -> q'
    newScore =
      if q.correctAnswer == answerId then state.score + 1 else state.score
    answeredQuestion = Question $ q { chosenAnswer = Just answerId }
    newQuestions =
      fromJust $ updateAt questionId answeredQuestion state.questions

-- | we only want to *actually* add the question if we're waiting for it.
-- | otherwise, we just return the state as is
appendQuestion :: Question -> State -> State
appendQuestion question state =
  if state.waitingForQuestion
  then state { questions          = snoc state.questions question,
               waitingForQuestion = false }
  else state

-- How to update the state (and perform effects) for each action type.
update :: forall eff. Update (ajax    :: AJAX,
                              err     :: EXCEPTION,
                              console :: CONSOLE    | eff) State Action
update action state input =
  case action of
    -- for a NewGame action, we need to reset the state to the initialState
    -- and make an AJAX request for a new question
    NewGame ->
      { state: initialState
      , effects: [ requestQuestion ] }
    -- for a click on an answer, update the state with the clicked answer,
    -- and make an AJAX request for a new question
    ClickAnswer questionId answerId ->
      { state: answerClicked questionId answerId state
      , effects: [ requestQuestion ]
      }
    -- for the result of a new question AJAX call, try to update the state
    QuestionReceived question ->
      { state: appendQuestion question state
      , effects: [] }
  where
    -- AJAX boilerplate that I don't totally understand
    requestQuestion =
      launchAff $ do
        res <- get questionServiceUrl
        let question = readJSON res.response :: F Question
        liftEff $ case question of
          (Left err) -> log "Error parsing JSON!"
          (Right question) -> S.send input (singleton (QuestionReceived question))

-- | An answer just gets rendered as a single div with classes to indicate
-- | whether its question has been answered, whether it's the right answer, and
-- | whether it's the chosen answer. If the question hasn't been answered yet,
-- | we add a click handler as well.
renderAnswer :: Question -> QuestionId -> Answer -> AnswerId -> VirtualDOM
renderAnswer (Question q) questionId answer answerId =
  div ! className classes ! clickHandlerIfUnanswered $ text answer
  where
    isAnswered = isJust q.chosenAnswer
    isChosen   = isAnswered && answerId == fromJust q.chosenAnswer
    isCorrect  = answerId == q.correctAnswer

    classes = joinWith " " $ map snd $ filter fst [
      Tuple true                          "answer",
      Tuple isChosen                      "chosen",
      Tuple (isAnswered && isCorrect)     "correct",
      Tuple (isAnswered && not isCorrect) "wrong"
    ]

    clickHandlerIfUnanswered =
      if isAnswered
      then Attrs [] [] -- no-op "attribute"
      else onClick (send $ ClickAnswer questionId answerId)

-- | VirtualDOM is a Monoid, so if we have an array of inputs `xs` and some
-- | function that maps each `x` to a VirtualDOM element, we can use `foldMap`
-- | to combine the results into a single VirtualDOM element. It turns out we'll
-- | need both an element and its index to create a VirtualDOM element; this
-- | helper function provides that `map`
foldMapWithIndex :: forall a. (a -> Int -> VirtualDOM) -> Array a -> VirtualDOM
foldMapWithIndex f xs = foldMap (uncurry f) pairs
  where pairs = zip xs (0 .. (length xs - 1))

-- | We render a question by displaying its questionText and then rendering its
-- | answers.
renderQuestion :: Question -> QuestionId -> VirtualDOM
renderQuestion (Question q) questionId = div $ do
  p ! className "question" $ text $ questionNumber ++ ". " ++ q.questionText
  foldMapWithIndex (renderAnswer (Question q) questionId) q.answers
  where
    questionNumber = show (questionId + 1)

view :: State -> VirtualDOM
view state = div $ do
  div ! className "sidebar" $ do
    p ! className "score" $ text ("Score: " ++ show state.score)
    button ! onClick (send NewGame) $ text "New Game"
    p ! className "twitter" $
      a ! href "http://twitter.com/joelgrus" $ text "@joelgrus"
    p ! className "github" $
      a ! href "https://github.com/joelgrus/science-questions" $
        img ! src "octocat.png"
  foldMapWithIndex renderQuestion state.questions

main = renderToDOM "#app" =<< app
  { state: initialState
  , update: update
  , view: view
  , inputs: []
  }

module Main where

import Prelude hiding (div)

import Control.Bind ((=<<))
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.Eff.Console (CONSOLE(), log)
import Data.Array (concat, filter, length, zip, (..), modifyAt, snoc)
import Data.Array.Unsafe (unsafeIndex)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust)
import Data.Maybe.Unsafe (fromJust)
import Data.Foldable (foldMap)
import Data.Foreign
import Data.Foreign.Class (IsForeign, readProp, readJSON)
import Data.List (singleton)
import Data.String (joinWith)
import Data.Tuple (fst, snd, uncurry, Tuple(..))
import Network.HTTP.Affjax (AJAX(), get)
import Pux
import Pux.DOM.HTML.Elements (a, img, div, p, button, text)
import Pux.DOM.HTML.Attributes (href, src, onClick, send, className)
import Pux.Render.DOM
import qualified Signal.Channel as S

questionServiceUrl :: String
--questionServiceUrl = "http://localhost:8080/question"
questionServiceUrl = "http://54.174.99.38/question"

-- | We define a newtype for Question so we can create an IsForeign instance.
newtype Question = Question {
  questionText  :: String,
  answers       :: Array Answer,
  correctAnswer :: AnswerId,
  chosenAnswer  :: Maybe AnswerId  -- which answer the player clicked on
}

type QuestionId = Int
type Answer = String
type AnswerId = Int

-- | Deserializing from JSON is pretty straightforward, we just need to add an
-- | extra Nothing value for chosenAnswer.
instance questionIsForeign :: IsForeign Question where
  read value = do
    questionText  <- readProp "questionText"  value
    answers       <- readProp "answers"       value
    correctAnswer <- readProp "correctAnswer" value
    return $ Question {
      questionText : questionText,
      answers : answers,
      correctAnswer : correctAnswer,
      chosenAnswer : Nothing
    }

data Action =
    NewGame                          -- start a new game
  | ClickAnswer QuestionId AnswerId  -- click on an answer
  | QuestionReceived Question        -- receive an AJAX response with a question

type State = {
  score              :: Int,
  questions          :: Array Question,
  waitingForQuestion :: Boolean -- are we waiting for an AJAX call to return?
}

-- | Start out with no questions.
initialState :: State
initialState = { score: 0, questions: [], waitingForQuestion: true }

-- | When you click on questionId answerId, we need to update the score,
-- | set the chosenAnswer field for that question, and set the
-- | waitingForQuestion flag.
answerClicked :: QuestionId -> AnswerId -> State -> State
answerClicked questionId answerId state =
  { score : newScore, questions: newQuestions, waitingForQuestion: true }
  where
    isCorrect = case state.questions `unsafeIndex` questionId of
      Question q | q.correctAnswer == answerId -> true
      _ -> false
    newScore = if isCorrect then state.score + 1 else state.score
    newQuestions = fromJust $ modifyAt questionId updateChosen state.questions
    updateChosen (Question q) = Question $ q { chosenAnswer = Just answerId }

-- | we only want to *actually* add the question if we're waiting for it.
-- | otherwise, we just return the state as is
appendQuestion :: Question -> State -> State
appendQuestion question state =
  if state.waitingForQuestion
  then state { questions = snoc state.questions question,
               waitingForQuestion = false }
  else state

-- How to update the state (and perform effects) for each action type.
update :: forall eff. Update (ajax    :: AJAX,
                              err     :: EXCEPTION,
                              console :: CONSOLE    | eff) State Action
update action state input =
  case action of
    -- for a NewGame action, we need to reset the state to the initialState
    -- and make an AJAX request for a new question
    NewGame ->
      { state: initialState
      , effects: [ requestQuestion ] }
    -- for a click on an answer, update the state with the clicked answer,
    -- and make an AJAX request for a new question
    ClickAnswer questionId answerId ->
      { state: answerClicked questionId answerId state
      , effects: [ requestQuestion ]
      }
    -- for the result of a new question AJAX call, try to update the state
    QuestionReceived question ->
      { state: appendQuestion question state
      , effects: [] }
  where
    -- AJAX boilerplate that I don't totally understand
    requestQuestion =
      launchAff $ do
        res <- get questionServiceUrl
        let question = readJSON res.response :: F Question
        liftEff $ case question of
          (Left err) -> log "Error parsing JSON!"
          (Right question) -> S.send input (singleton (QuestionReceived question))

-- | An answer just gets rendered as a single div with classes to indicate
-- | whether its question has been answered, whether it's the right answer, and
-- | whether it's the chosen answer. If the question hasn't been answered yet,
-- | we add a click handler as well.
renderAnswer :: Question -> QuestionId -> Answer -> AnswerId -> VirtualDOM
renderAnswer (Question q) questionId answer answerId =
  div ! className classes ! clickHandlerIfUnanswered $ text answer
  where
    isAnswered = isJust q.chosenAnswer
    isChosen   = isAnswered && answerId == fromJust q.chosenAnswer
    isCorrect  = isAnswered && answerId == q.correctAnswer

    classes = joinWith " " $ map snd $ filter fst [
      Tuple true                          "answer",
      Tuple (isAnswered && isChosen)      "chosen",
      Tuple (isAnswered && isCorrect)     "correct",
      Tuple (isAnswered && not isCorrect) "wrong"
    ]

    clickHandlerIfUnanswered =
      if isAnswered
      then Attrs [] [] -- no-op "attribute"
      else onClick (send $ ClickAnswer questionId answerId)

-- | VirtualDOM is a Monoid, so if we have an array of inputs `xs` and some
-- | function that maps each `x` to a VirtualDOM element, we can use `foldMap`
-- | to combine the results into a single VirtualDOM element. It turns out we'll
-- | need both an element and its index to create a VirtualDOM element; this
-- | helper function provides that `map`
foldMapWithIndex :: forall a. (a -> Int -> VirtualDOM) -> Array a -> VirtualDOM
foldMapWithIndex f xs = foldMap (uncurry f) pairs
  where pairs = zip xs (0 .. (length xs - 1))

-- | We render a question by displaying its questionText and then rendering its
-- | answers.
renderQuestion :: Question -> QuestionId -> VirtualDOM
renderQuestion (Question q) questionId = div $ do
  p ! className "question" $ text $ questionNumber ++ q.questionText
  foldMapWithIndex (renderAnswer (Question q) questionId) q.answers
  where
    questionNumber = show (questionId + 1) ++ ". "

view :: State -> VirtualDOM
view state = div $ do
  div ! className "sidebar" $ do
    p ! className "score" $ text ("Score: " ++ show state.score)
    button ! onClick (send NewGame) $ text "New Game"
    p ! className "twitter" $
      a ! href "http://twitter.com/joelgrus" $ text "@joelgrus"
    p ! className "github" $
      a ! href "https://github.com/joelgrus/science-questions" $
        img ! src "octocat.png"
  foldMapWithIndex renderQuestion state.questions

main = renderToDOM "#app" =<< app
  { state: initialState
  , update: update
  , view: view
  , inputs: []
  }


Be explicit so I don't get confused again here

Original commit 847dce4018e4d8b161b6f49d608219a369489764

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    ) where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline a = Doc.Renderer -> a -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema renderer json = do
    schema <- J.decodeJson json
    graph <- makeTypeFromSchema "TopLevel" schema
    graph
        # regatherClassNames
        # Doc.runRenderer renderer
        # pure

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJsonSchema, renderFromJson]
pipelines Production = [renderFromJson]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes renderer json = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

renderFromJsonStringPossiblyAsSchemaInDevelopment :: Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment renderer jsonString = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) renderer obj

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonString
    , renderers
    ) where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline a = Doc.Renderer -> a -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema renderer json = do
    schema <- J.decodeJson json
    graph <- makeTypeFromSchema "TopLevel" schema
    graph
        # regatherClassNames
        # Doc.runRenderer renderer
        # pure

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJsonSchema, renderFromJson]
pipelines Production = [renderFromJson]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes renderer json = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

relax :: Pipeline Json -> Pipeline String
relax pipeline renderer jsonString = do
    obj <- J.jsonParser jsonString
    pipeline renderer obj

-- Depending on the environment, treat a JSON string as a JSON schema
-- or fallback on rendering as a simple JSON document
renderFromJsonString :: Pipeline String
renderFromJsonString = relax $ firstSuccess (pipelines Env.current)


Update

Update

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Monad.Eff (Eff, forE)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
--import Data.List
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

vertices :: Array Point3D
vertices =
    [Point3D (-100.0) 100.0 (-100.0)
    ,Point3D 100.0 100.0 (-100.0)
    ,Point3D 100.0 (-100.0) (-100.0)
    ,Point3D (-100.0) (-100.0) (-100.0)
    ,Point3D (-100.0) 100.0 100.0
    ,Point3D 100.0 100.0 100.0
    ,Point3D 100.0 (-100.0) 100.0
    ,Point3D (-100.0) (-100.0) 100.0
  ]

data Point3D = Point3D Number Number Number

data Angle3D = Angle3D
    {qx :: Number
    ,qy :: Number
    ,qz :: Number
    }

angle :: Angle3D
angle = Angle3D
    {qx: Math.pi/4.0
    ,qy: Math.pi/3.0
    ,qz: Math.pi/4.0
    }

data Face = Face Point3D Point3D Point3D Point3D

faces :: Array (Array Int)
faces = [
    [0,1,2,3],
    [1,5,6,2],
    [5,4,7,6],
    [4,0,3,7],
    [0,4,5,1],
    [3,2,6,7]
]

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D x y z) (Angle3D ang) =
    let xRotQz = x * Math.cos ang.qz + y * Math.sin ang.qz
        yRotQz = y * Math.cos ang.qz + x * Math.sin ang.qz
        zRotQz = z
        xRotQzQx = xRotQz
        yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
        zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
        xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
        yRotQzQxQy = yRotQzQx
    in
        (Point3D xRotQzQxQy yRotQzQxQy zRotQz)

projectAll3Dto2D :: (Array Point3D) -> Angle3D -> (Array Point3D)
projectAll3Dto2D vert3D ang =
    let
        vert2D = map (\v -> project3Dto2D v ang ) vert3D
    in
        vert2D

defVal1 :: Maybe Number -> Number
defVal1 val = fromMaybe 0.0 val

{-
defVal :: Maybe Point3D -> Point3D
defVal (Point3D x y z) =
    let
        dx = fromMaybe 0.0 x
        dy = fromMaybe 0.0 y
        dz = fromMaybe 0.0 z
    in
        (Point3D dx dy dz)
-}

drawFace :: forall e. Context2D -> Face -> Eff (canvas :: CANVAS | e) Unit
drawFace ctx (Face v1 v2 v3 v4) = strokePath ctx do
        ctx <- setStrokeStyle "#000000" ctx
        ctx <- moveTo ctx x1 y1
        ctx <- lineTo ctx x2 y2
        ctx <- lineTo ctx x3 y3
        ctx <- lineTo ctx x4 y4
        void $ closePath ctx
    where
        Point3D x1 y1 z1 = v1
        Point3D x2 y2 z2 = v2
        Point3D x3 y3 z3 = v3
        Point3D x4 y4 z4 = v4

drawCube :: forall e. Context2D -> (Array Point3D) -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx vert3D = strokePath ctx do
    --for faces $ \face -> do
    --  drawFace (map vert2D face)
    void $ forE 0 6 $ \i -> do
        let face = faces !! i
        let vertFace = []
        void $ forE 0 4 $ \j -> do
            cons (vert2D (face !! j)) vertFace
        drawFace vertFace
    where
        vert2D = projectAll3Dto2D vert3D angle

transform :: Point3D -> Point3D
transform (Point3D x y z) =
    let nx = x + 200.0
        ny = x + 200.0
    in
        (Point3D nx ny z)

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, console :: CONSOLE, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
    Just canvas <- getCanvasElementById "thecanvas"
    ctx <- getContext2D canvas
    animFrame <- animationFrame
    ctx <- setFillStyle "#0000FF" ctx
    --ctx <- fillRect{x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
    drawCube ctx vertices
    --log("working")

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Monad.Eff (Eff, forE)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
--import Data.List
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

data Point3D = Point3D Number Number Number

vertices :: Array Point3D
vertices =
	[Point3D (-100.0) 100.0 (-100.0)
	,Point3D 100.0 100.0 (-100.0)
	,Point3D 100.0 (-100.0) (-100.0)
	,Point3D (-100.0) (-100.0) (-100.0)
	,Point3D (-100.0) 100.0 100.0
	,Point3D 100.0 100.0 100.0
	,Point3D 100.0 (-100.0) 100.0
	,Point3D (-100.0) (-100.0) 100.0
  ]

data Angle3D = Angle3D
	{qx :: Number
	,qy :: Number
	,qz :: Number
	}

angle :: Angle3D
angle = Angle3D
	{qx: Math.pi/4.0
	,qy: Math.pi/3.0
	,qz: Math.pi/4.0
	}

data Face = Face Point3D Point3D Point3D Point3D

faces :: Array (Array Int)
faces = [
	[0,1,2,3],
	[1,5,6,2],
	[5,4,7,6],
	[4,0,3,7],
	[0,4,5,1],
	[3,2,6,7]
]

--getVertices :: Face
--getVertices

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D x y z) (Angle3D ang) =
	let	xRotQz = x * Math.cos ang.qz + y * Math.sin ang.qz
		yRotQz = y * Math.cos ang.qz + x * Math.sin ang.qz
		zRotQz = z
		xRotQzQx = xRotQz
		yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
		zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
		xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
		yRotQzQxQy = yRotQzQx
	in
		(Point3D xRotQzQxQy yRotQzQxQy zRotQz)

projectAll3Dto2D :: (Array Point3D) -> Angle3D -> (Array Point3D)
projectAll3Dto2D vert3D ang =
	let
		vert2D = map (\v -> project3Dto2D v ang ) vert3D
	in
		vert2D

defVal1 :: Maybe Number -> Number
defVal1 val = fromMaybe 0.0 val

{-
defVal :: Maybe Point3D -> Point3D
defVal (Point3D x y z) =
	let
		dx = fromMaybe 0.0 x
		dy = fromMaybe 0.0 y
		dz = fromMaybe 0.0 z
	in
		(Point3D dx dy dz)
-}

drawFace :: forall e. Context2D -> Face -> Eff (canvas :: CANVAS | e) Unit
drawFace ctx (Face v1 v2 v3 v4) = strokePath ctx do
		ctx <- setStrokeStyle "#000000" ctx
		ctx <- moveTo ctx x1 y1
		ctx <- lineTo ctx x2 y2
		ctx <- lineTo ctx x3 y3
		ctx <- lineTo ctx x4 y4
		void $ closePath ctx
	where
		Point3D x1 y1 z1 = v1
		Point3D x2 y2 z2 = v2
		Point3D x3 y3 z3 = v3
		Point3D x4 y4 z4 = v4

drawCube :: forall e. Context2D -> (Array Point3D) -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx vert3D = strokePath ctx do
	--for faces $ \face -> do
	--	drawFace (map vert2D face)
	void $ forE 0 6 $ \i -> do
		let face = faces !! i
		let vertFace = []
		void $ forE 0 4 $ \j -> do
			cons (vert2D (face !! j)) vertFace
		drawFace vertFace
	where
		vert2D = projectAll3Dto2D vert3D angle

transform :: Point3D -> Point3D
transform (Point3D x y z) =
	let	nx = x + 200.0
		ny = x + 200.0
	in
		(Point3D nx ny z)

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, console :: CONSOLE, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
	Just canvas <- getCanvasElementById "thecanvas"
	ctx <- getContext2D canvas
	animFrame <- animationFrame
	ctx <- setFillStyle "#0000FF" ctx
	--ctx <- fillRect{x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
	drawCube ctx vertices
	--log("working")


Add try

Add try

Fixes #94.

-- | This module defines the `MonadError` type class and its instances.

module Control.Monad.Error.Class where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)

-- | The `MonadThrow` type class represents those monads which support errors via
-- | `throwError`, where `throwError e` halts, yielding the error `e`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Left zero: `throwError e >>= f = throwError e`
-- |
class Monad m <= MonadThrow e m | m -> e where
  throwError :: forall a. e -> m a

-- | The `MonadError` type class represents those monads which support catching
-- | errors.
-- |
-- | - `catchError x f` calls the error handler `f` if an error is thrown during the
-- |   evaluation of `x`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Catch: `catchError (throwError e) f = f e`
-- | - Pure: `catchError (pure a) f = pure a`
-- |
class MonadThrow e m <= MonadError e m | m -> e where
  catchError :: forall a. m a -> (e -> m a) -> m a

-- | This function allows you to provide a predicate for selecting the
-- | exceptions that you're interested in, and handle only those exceptons.
-- | If the inner computation throws an exception, and the predicate returns
-- | Nothing, then the whole computation will still fail with that exception.
catchJust
  :: forall e m a b
   . MonadError e m
  => (e -> Maybe b) -- ^ Predicate to select exceptions
  -> m a            -- ^ Computation to run
  -> (b -> m a)     -- ^ Handler
  -> m a
catchJust p act handler = catchError act handle
  where
  handle e =
    case p e of
      Nothing -> throwError e
      Just b -> handler b

-- | Return `Right` if the given action succeeds, `Left` if it throws.
try
  :: forall e m a
   . MonadError e m
  => m a
  -> m (Either e a)
try a = (Right <$> a) `catchError` (pure <<< Left)

instance monadThrowEither :: MonadThrow e (Either e) where
  throwError = Left

instance monadErrorEither :: MonadError e (Either e) where
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadThrowMaybe :: MonadThrow Unit Maybe where
  throwError = const Nothing

instance monadErrorMaybe :: MonadError Unit Maybe where
  catchError Nothing f  = f unit
  catchError (Just a) _ = Just a

-- | Make sure that a resource is cleaned up in the event of an exception. The
-- | release action is called regardless of whether the body action throws or
-- | returns.
withResource
  :: forall e m r a
   . MonadError e m
  => m r
  -> (r -> m Unit)
  -> (r -> m a)
  -> m a
withResource acquire release kleisli = do
  resource <- acquire
  result <- try $ kleisli resource
  release resource
  either throwError pure result

-- | This module defines the `MonadError` type class and its instances.

module Control.Monad.Error.Class where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)

-- | The `MonadThrow` type class represents those monads which support errors via
-- | `throwError`, where `throwError e` halts, yielding the error `e`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Left zero: `throwError e >>= f = throwError e`
-- |
class Monad m <= MonadThrow e m | m -> e where
  throwError :: forall a. e -> m a

-- | The `MonadError` type class represents those monads which support catching
-- | errors.
-- |
-- | - `catchError x f` calls the error handler `f` if an error is thrown during the
-- |   evaluation of `x`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Catch: `catchError (throwError e) f = f e`
-- | - Pure: `catchError (pure a) f = pure a`
-- |
class MonadThrow e m <= MonadError e m | m -> e where
  catchError :: forall a. m a -> (e -> m a) -> m a

-- | This function allows you to provide a predicate for selecting the
-- | exceptions that you're interested in, and handle only those exceptons.
-- | If the inner computation throws an exception, and the predicate returns
-- | Nothing, then the whole computation will still fail with that exception.
catchJust
  :: forall e m a b
   . MonadError e m
  => (e -> Maybe b) -- ^ Predicate to select exceptions
  -> m a            -- ^ Computation to run
  -> (b -> m a)     -- ^ Handler
  -> m a
catchJust p act handler = catchError act handle
  where
  handle e =
    case p e of
      Nothing -> throwError e
      Just b -> handler b

instance monadThrowEither :: MonadThrow e (Either e) where
  throwError = Left

instance monadErrorEither :: MonadError e (Either e) where
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadThrowMaybe :: MonadThrow Unit Maybe where
  throwError = const Nothing

instance monadErrorMaybe :: MonadError Unit Maybe where
  catchError Nothing f  = f unit
  catchError (Just a) _ = Just a

-- | Make sure that a resource is cleaned up in the event of an exception. The
-- | release action is called regardless of whether the body action throws or
-- | returns.
withResource
  :: forall e m r a
   . MonadError e m
  => m r
  -> (r -> m Unit)
  -> (r -> m a)
  -> m a
withResource acquire release kleisli = do
  resource <- acquire
  result <- (Right <$> kleisli resource) `catchError` (pure <<< Left)
  release resource
  either throwError pure result


simplify chooseInt a bit

simplify chooseInt a bit

make the logic a bit more readable

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (state, modify)

import Data.Array ((!!), length)
import Data.Foldable (fold)
import Data.Int (toNumber, floor)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)

import Math ((%))

import Test.QuickCheck.LCG (Seed, lcgPerturb, lcgN, lcgNext, runSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max' - min') >>> (+) min' <$> uniform where
  min' = min a b
  max' = max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
-- | Note that very large intervals will cause a loss of uniformity.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = if a <= b then chooseInt' a b else chooseInt' b a

-- guaranteed a <= b
chooseInt' :: Int -> Int -> Gen Int
chooseInt' a b = floor <<< clamp <$> choose32BitPosNumber
  where
    choose32BitPosNumber :: Gen Number
    choose32BitPosNumber = (+) <$> choose31BitPosNumber <*> choose31BitPosNumber

    choose31BitPosNumber :: Gen Number
    choose31BitPosNumber = toNumber <$> lcgStep

    clamp :: Number -> Number
    clamp x = numA + (x % (numB - numA + one))

    numA = toNumber a
    numB = toNumber b

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ Tuple x xs

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (state, modify)

import Data.Array ((!!), length)
import Data.Foldable (fold)
import Data.Int (toNumber, floor)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)

import Math ((%))

import Test.QuickCheck.LCG (Seed, lcgPerturb, lcgN, lcgNext, runSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max' - min') >>> (+) min' <$> uniform where
  min' = min a b
  max' = max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = floor <<< clamp <$> choose32BitNumber
  where
  choose32BitNumber :: Gen Number
  choose32BitNumber = (+) <$> choose31BitNumber <*> choose31BitNumber

  choose31BitNumber :: Gen Number
  choose31BitNumber = toNumber <$> lcgStep

  clamp :: Number -> Number
  clamp x = case x % (numB - numA + one) of
              r | r >= 0.0 -> numA + r
                | otherwise -> numB + r + one
  numA = toNumber a
  numB = toNumber b

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ Tuple x xs

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen