more work on Types

more work on Types

module Test.Main where

import Prelude
import Control.Monad.Eff (Eff)
--import Control.Monad.Aff (launchAff)
--import Control.Monad.Aff.Console (CONSOLE, log, logShow)
import Control.Monad.Eff.Console (CONSOLE, log, logShow)
--import Control.Monad.Eff.Exception (EXCEPTION)
--import Node.FS (FS)
--import Node.Encoding (Encoding(..))
--import Node.FS.Sync (readTextFile)
--import Node.FS.Aff (readTextFile)
--import Node.Path (FilePath)
--import Data.String.Utils (words)

import Data.Tuple ( Tuple(..) )
import Data.Array ( (!!), mapMaybe )
import Data.Maybe (Maybe (..) )
import Data.List ( List(..),  (:) )
import Data.Foldable ( traverse_ )

import FV.Types ( HMeas (..), VHMeas (..), vertex, helices, fromHMeas, typeShow )
import Test.Input ( hSlurp, hSlurpMCtruth )
import Data.Matrix  ( Matrix, identity, zero_, matrix, fromList2, getElem, diagonal
                    , multStd
                    , toLists, fromLists, fromList
                    , nrows, ncols
                    )

import Data.Number ( fromString )
import Stuff

showMomentum :: forall e. HMeas -> Eff (console :: CONSOLE | e) Unit
showMomentum h = log $ "pt,pz,fi,E ->" <> (show <<< fromHMeas) h
showHelix :: forall e. HMeas -> Eff (console :: CONSOLE | e) Unit
showHelix h = log $ "Helix ->" <> (show h)

main :: forall e.  Eff ( console :: CONSOLE
                       --, exception :: EXCEPTION
                       --, fs :: FS
                       | e) Unit
--main = void $ launchAff do
main = do
  log "FVT Test Suite"
  log "--Test hSlurp"
  testHSlurp
  log "--Test Matrix"
  testMatrix
  log "--Test FVT"
  testFVT

testFVT :: forall e. Eff (console :: CONSOLE | e) Unit
testFVT = do
  let vm = hSlurp tr05129e001412
  let hel = case vm of
              Just v -> helices v
              Nothing -> []
  traverse_ showHelix hel
  traverse_ showMomentum hel
  {-- let l5 = [0,2,3,4,5] -- these are the tracks supposedly from the tau --}
  {-- doFitTest vm l5 --}
  {-- _ <- showProng <<< fitw <<< hFilter l5 <<< vBlowup 10000.0 $ vm --}

testHSlurp :: forall e. Eff (console :: CONSOLE | e) Unit
testHSlurp = do
  log "Test hSlurp dat/tr05129e001412.dat"
  {-- ds <- readTextFile UTF8 "dat/tr05129e001412.dat" --}
  {-- let ws = mapMaybe fromString $ words ds --}
  let ws = tr05129e001412
  log "Test hSlurp dat/tav-4.dat"
  logShow $ mapMaybe fromString $ words tav4
  logShow $ hSlurp tav4
  logShow $ hSlurp ws
  --logShow =<< hSlurp tav4
  let mc = hSlurpMCtruth tav4
  logShow mc

testMatrix :: forall e. Eff (console :: CONSOLE | e) Unit
testMatrix = do
  log $ "Test identity 3"
  logShow $ identity 3
  log $ "Test zero 3 3"
  logShow $ zero_ 3 3
  log "Test Matrix operations: identity == zero?"
  logShow $ (identity 3) == (zero_ 3 3)
  log $ "Test matrix creation"
  let m0 = matrix 3 3 $ \(Tuple i j) -> 2*i - j
  logShow $ Tuple (m0 == (fromList2 3 3 [1,0,-1,3,2,1,5,4,3])) m0
  let m1 = matrix 3 4 $ \(Tuple i j) -> 2*i - j
  logShow $ Tuple (m1 == (fromList2 3 3 [1,0,-1,3,2,1,5,4,3])) m1

  log $ "Test getElem"
  let e1 = getElem 3 4 m1
  logShow $ Tuple (e1 == 2) e1

  log $ "Test fromLists"
  let ll0 :: List (Array Int)
      ll0 = [1,0,0] : [0,2,0] : [0,0,3] : Nil
      ll1 = fromLists ll0
  logShow $ Tuple (ll1 == diagonal 0 [1,2,3]) ll0

  log $ "Test toLists"
  let l0 = diagonal 0 [1,2,3]
      l1 = toLists l0 !! 2
  logShow $ Tuple (l1 == Just [0,0,3]) l1

  log $ "Test arithmetic"
  let m35 = fromLists $ [1,2,3,4,5] : [2,3,4,5,6] : [3,4,5,6,7] : Nil
      m53 = fromLists $ [1,0,0] : [0,1,0] : [0,0,1] : [0,0,0] : [0,0,0] : Nil
      d5n = diagonal 0.0 [2.0, 2.0, 2.0, 2.0, 2.0]
      d5 = diagonal 0 [2, 2, 2, 2, 2]
  logShow $ m35 * m53 == (fromLists $ [1,2,3] : [2,3,4] : [3,4,5] : Nil)
  logShow $ m35 * m53
  logShow $ (diagonal 0 [1,1,1,1,1]) + (diagonal 0 [1,1,1,1,1]) == (diagonal 0 [2,2,2,2,2])
  logShow $ (fromList2 3 3 [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0]) * one
  logShow $ (fromList2 3 3 [1,2,3,4,5,6,7,8,9]) * one
  logShow $ (fromList2 3 3 [0,0,1,0,1,0,1,0,0]) * (fromList2 3 3 [11, 12,13,21,22,23,31,32,33]) * one
  logShow $ (fromList2 3 3 [11, 12,13,21,22,23,31,32,33]) * fromList 3 [-1,1,1]

  log "Test typeShow"
  log $ typeShow
  {-- {1-- (VHMeas _ hl, _) <- hSlurp "dat/tav-0.dat" --1} --}
  {-- {1-- let HMeas _ _ w = head hl --1} --}
  {-- {1-- w `shouldBe` 0.0114 --1} --}

tr05129e001412 :: String
tr05129e001412 = """
   3.355679512023926       3.489715576171875       7.110095977783203
  0.2884106636047363      0.2967556118965149      0.4457152485847473
  0.2967556118965149      0.3057302236557007      0.4589158892631531
  0.4457152485847473      0.4589158892631531      0.7007381319999695
  4.5451703E-03
           6
  9.0513890609145164E-04   1.174186706542969      0.7913663387298584
 -5.4129425436258316E-02   1.309153556823730
  3.0409931517372257E-11  3.0817798313265143E-10 -2.6150961396353978E-09
 -6.2086684238238377E-08  1.9006475560079394E-10  3.0817798313265143E-10
  3.5358195873413933E-06 -5.5664237663677341E-09 -4.7704439509743679E-08
 -3.5389247932471335E-04 -2.6150961396353978E-09 -5.5664237663677341E-09
  3.9334932466772443E-07  9.2603177108685486E-06 -4.2692363422247581E-07
 -6.2086684238238377E-08 -4.7704439509743679E-08  9.2603177108685486E-06
  2.7857377426698804E-04 -1.2511900422396138E-05  1.9006475560079394E-10
 -3.5389247932471335E-04 -4.2692363422247581E-07 -1.2511900422396138E-05
  4.6403184533119202E-02
 -3.2948562875390053E-04  -1.287435531616211       3.964143753051758
 -5.5920504033565521E-02   2.172087669372559
  1.0773015292342425E-11  1.0870629917059116E-11 -9.4798713323740458E-10
 -2.6224558524745589E-08  5.1304871462320989E-10  1.0870629917059116E-11
  1.3991236755828140E-06  6.1739335865951261E-11  3.9363889925425610E-09
 -1.3362320896703750E-04 -9.4798713323740458E-10  6.1739335865951261E-11
  1.0642112613368226E-07  3.0040880574233597E-06 -5.7571856615368233E-08
 -2.6224558524745589E-08  3.9363889925425610E-09  3.0040880574233597E-06
  1.0815335554070771E-04 -1.6780244322944782E-06  5.1304871462320989E-10
 -1.3362320896703750E-04 -5.7571856615368233E-08 -1.6780244322944782E-06
  1.5890464186668396E-02
  8.6099491454660892E-04   1.190025329589844      0.7718949913978577
  -1.004449844360352       4.974927902221680
  7.8076378695612902E-10 -2.4755367200590683E-10 -1.0359136126680824E-07
 -6.7278465394338127E-06  4.4596313841793744E-07 -2.4755367200590683E-10
  6.6328821048955433E-06  2.8732655366070503E-08  1.5816522136447020E-06
 -8.9828821364790201E-04 -1.0359136126680824E-07  2.8732655366070503E-08
  1.3829509043716826E-05  9.0345303760841489E-04 -5.9563441027421504E-05
 -6.7278465394338127E-06  1.5816522136447020E-06  9.0345303760841489E-04
  5.9390719980001450E-02 -3.8860931526869535E-03  4.4596313841793744E-07
 -8.9828821364790201E-04 -5.9563441027421504E-05 -3.8860931526869535E-03
  0.1251238286495209
 -1.7263018526136875E-03   1.039703369140625      0.8659646511077881
  0.2599024176597595       2.128120422363281
  1.5148657328545312E-10 -7.3402152411805588E-11 -1.4714315987873761E-08
 -6.3192055677063763E-07 -3.4522088299127063E-08 -7.3402152411805588E-11
  1.5436929743373184E-06 -5.5447091362736955E-10 -8.1613094948806975E-08
 -1.5131152758840472E-04 -1.4714315987873761E-08 -5.5447091362736955E-10
  1.5367089645224041E-06  6.8635607021860778E-05  4.2090109673154075E-06
 -6.3192055677063763E-07 -8.1613094948806975E-08  6.8635607021860778E-05
  3.2065853010863066E-03  1.9913408323191106E-04 -3.4522088299127063E-08
 -1.5131152758840472E-04  4.2090109673154075E-06  1.9913408323191106E-04
  1.7373077571392059E-02
  1.2108741793781519E-03   1.282915115356445      0.8532057404518127
  8.5045360028743744E-03   1.965600013732910
  3.6512477069594595E-11  8.9357354848829118E-10 -3.3482463468459400E-09
 -8.1875484170268464E-08  9.6036401053822829E-10  8.9357354848829118E-10
  3.0787202831561444E-06 -2.2171841251861224E-08 -2.7003440550288360E-07
 -1.5695679758209735E-04 -3.3482463468459400E-09 -2.2171841251861224E-08
  5.5774097518224153E-07  1.3075616152491421E-05 -4.9851792027766351E-07
 -8.1875484170268464E-08 -2.7003440550288360E-07  1.3075616152491421E-05
  3.5224124439992011E-04 -1.4417236343433615E-05  9.6036401053822829E-10
 -1.5695679758209735E-04 -4.9851792027766351E-07 -1.4417236343433615E-05
  1.7541546374559402E-02
 -7.3608336970210075E-04   1.297574043273926      0.8316786885261536
  -1.011060714721680      -2.867138862609863
  2.0176718074083055E-09  9.1418789205377493E-10 -2.5551665316925209E-07
 -1.5318933947128244E-05 -3.4175937457803229E-07  9.1418789205377493E-10
  7.4829795266850851E-06 -1.1038221003900617E-07 -6.1672653828281909E-06
 -9.3757675494998693E-04 -2.5551665316925209E-07 -1.1038221003900617E-07
  3.2483072573086247E-05  1.9545238465070724E-03  4.3123862269567326E-05
 -1.5318933947128244E-05 -6.1672653828281909E-06  1.9545238465070724E-03
  0.1181144416332245      2.5763250887393951E-03 -3.4175937457803229E-07
 -9.3757675494998693E-04  4.3123862269567326E-05  2.5763250887393951E-03
  0.1227073818445206
"""
tav4 :: String
tav4 = """PU_zpositions:  190 4.06972837448 2.44204807281 7.82136058807 -0.621172726154 -6.80061435699 -1.73116350174 -5.42739343643 -7.10662841797 -6.32562208176 -3.72315001488 1.66695046425 6.55822181702 -7.12538957596 -0.389555871487 -2.8334877491 3.09819436073 -5.65534687042 12.068236351 -1.79448211193 5.73383188248 1.68428444862 2.1804420948 8.66328144073 -12.8040647507 -1.1730145216 -3.57441878319 6.21948480606 -1.26211774349 -3.4871032238 -9.48501300812 -8.33902263641 -1.71619582176 -1.56027853489 1.49686825275 -1.69698286057 1.69038307667 5.10251283646 -2.57128977776 0.749759852886 -2.58463263512 -9.792719841 -8.84095287323 -0.131224393845 -1.56865620613 -5.81232976913 4.21827507019 -4.92665529251 -5.84215211868 -5.74135446548 3.38353490829 -3.13945651054 4.30185222626 -12.6121692657 1.54116880894 1.38944470882 -6.84423398972 2.88845825195 -4.16181087494 6.3093957901 -1.70226609707 3.62256598473 -1.38095474243 1.69552695751 -9.44017601013 2.82410240173 -2.21053552628 2.34878325462 -8.67048835754 1.25067412853 9.49777984619 8.16330623627 -0.870663702488 -4.79498910904 1.78941035271 -7.03154611588 1.68979644775 -0.484967201948 -4.18258905411 0.0788396298885 -4.69477128983 2.32463097572 -2.10498857498 -5.34199571609 3.32180857658 -5.39752531052 -2.84948658943 -2.68618583679 1.0778503418 0.443690419197 -3.29635429382 0.936188876629 -4.41851854324 -3.29131436348 2.12316703796 -10.6452322006 -14.0393047333 3.74121594429 -8.4497051239 -5.68886137009 8.31489753723 -4.49255418777 -7.92309999466 -7.26154613495 -2.43943715096 2.87128973007 -8.41958713531 -5.04697036743 -2.6269865036 -3.01578998566 5.666908741 4.7386713028 4.83959341049 -12.2599534988 6.80844593048 -7.59651374817 1.77152347565 -3.49425053596 4.14569759369 2.39712738991 0.695241510868 0.351206511259 -1.00542604923 -0.592145264149 8.05185890198 1.35937333107 -3.23685288429 1.82836604118 -1.08040130138 -4.06748771667 -1.22976350784 -5.24559354782 4.77764129639 -7.92655897141 6.87241268158 8.90295886993 -10.4462614059 5.51054620743 4.28739690781 -0.413518726826 -2.84266161919 -4.82323074341 -3.47484374046 -6.56179046631 -5.6174902916 2.68036007881 -4.87207984924 -3.47317409515 -1.94823920727 -11.0047950745 -6.04952716827 -12.1523780823 -0.171474739909 1.82068359852 -11.1572389603 -2.97859430313 -3.65392804146 1.67614769936 -4.62239599228 4.72258663177 -3.13622426987 -9.94389533997 -13.6851511002 1.98555517197 4.60026597977 -10.9611978531 -1.63044011593 8.50263690948 -9.76078033447 0.933302462101 6.68330335617 -2.94098043442 -8.59897899628 -0.908704698086 -5.6248884201 -9.19552707672 -6.67034435272 3.34288668633 -2.66896915436 -5.85388660431 -6.08788156509 -9.28157234192 -3.39719057083 -2.08446788788 3.61256814003 4.3055267334 -3.20882606506 -1.37032854557 6.3657708168 -7.99672412872 7.93814659119
0.104794 0.168646 -1.00377 0.0015033299569 0.0 0.0 0.0 0.00151841994375 0.0 0.0 0.0 5.21037006378
1.0
4
-0.450663641447 1.35035226203 1.18063795337 0.0660153061812 -1.23642665653 1.75648085587e-06 1.09397257919e-09 2.97465732046e-07 -4.61079963543e-07 -2.34128183507e-08 1.09397257919e-09 1.44003013247e-06 8.51150190329e-08 2.84054323174e-07 -1.69398772414e-05 2.97465732046e-07 8.51150190329e-08 3.07370719383e-05 -7.83819778007e-05 -3.34401283908e-06 -4.61079963543e-07 2.84054323174e-07 -7.83819778007e-05 0.000201181290322 2.55465602095e-06 -2.34128183507e-08 -1.69398772414e-05 -3.34401283908e-06 2.55465602095e-06 0.000202862953302
0.425837572723 -1.33656916571 -0.200853553729 0.186440212098 0.447653308602 4.94152754982e-06 -1.85234905192e-09 7.72127236814e-07 -1.24222322029e-06 -3.99287580777e-09 -1.85234905192e-09 1.2965380165e-06 1.72925282982e-08 4.64915046905e-07 -1.68021942955e-05 7.72127236814e-07 1.72925282982e-08 2.40928802668e-05 -7.24880374037e-05 -2.46094759859e-06 -1.24222322029e-06 4.64915046905e-07 -7.24880374037e-05 0.000219607783947 7.73318163283e-07 -3.99287580777e-09 -1.68021942955e-05 -2.46094759859e-06 7.73318163283e-07 0.000218317465624
0.292514034965 1.39665579944 -0.993975573833 0.141543926193 0.40182813437 6.18352771653e-07 2.45095588269e-09 2.34424803125e-07 -8.39045242174e-07 -8.35598825688e-08 2.45095588269e-09 8.66051891535e-07 4.61750582215e-10 -3.98558910319e-07 -1.4314922737e-05 2.34424803125e-07 4.61750582215e-10 2.8809732612e-05 -8.27241237857e-05 2.18257969209e-06 -8.39045242174e-07 -3.98558910319e-07 -8.27241237857e-05 0.000238582899328 4.61562564169e-07 -8.35598825688e-08 -1.4314922737e-05 2.18257969209e-06 4.61562564169e-07 0.000236972875427
-0.29652562498 1.37864870921 -1.02387889924 0.192178996941 0.0749212341852 1.4916007558e-06 5.99006577673e-09 7.09483913397e-07 -2.9230166092e-06 -3.92529898363e-07 5.99006577673e-09 7.67293840909e-07 5.73736658183e-09 2.58630308281e-07 -1.14107451736e-05 7.09483913397e-07 5.73736658183e-09 2.14707033592e-05 -6.15742173977e-05 -1.75877414677e-06 -2.9230166092e-06 2.58630308281e-07 -6.15742173977e-05 0.000178089467227 1.27894770685e-06 -3.92529898363e-07 -1.14107451736e-05 -1.75877414677e-06 1.27894770685e-06 0.000170099316165
"""

module Test.Main where

import Prelude
import Control.Monad.Eff (Eff)
--import Control.Monad.Aff (launchAff)
--import Control.Monad.Aff.Console (CONSOLE, log, logShow)
import Control.Monad.Eff.Console (CONSOLE, log, logShow)
--import Control.Monad.Eff.Exception (EXCEPTION)
--import Node.FS (FS)
--import Node.Encoding (Encoding(..))
--import Node.FS.Sync (readTextFile)
--import Node.FS.Aff (readTextFile)
--import Node.Path (FilePath)
--import Data.String.Utils (words)

import Data.Tuple ( Tuple(..) )
import Data.Array ( (!!), mapMaybe )
import Data.Maybe (Maybe (..) )
import Data.List ( List(..),  (:) )
import Data.Foldable ( traverse_ )

import FV.Types ( HMeas (..), VHMeas (..), vertex, helices, typeShow )
import Test.Input ( hSlurp, hSlurpMCtruth )
import Data.Matrix  ( Matrix, identity, zero_, matrix, fromList2, getElem, diagonal
                    , multStd
                    , toLists, fromLists, fromList
                    , nrows, ncols
                    )

import Data.Number ( fromString )
import Stuff

showMomentum :: forall e. HMeas -> Eff (console :: CONSOLE | e) Unit
showMomentum h = log $ "pt,pz,fi,E ->" -- <> (show <<< h2q) h
showHelix :: forall e. HMeas -> Eff (console :: CONSOLE | e) Unit
showHelix h = log $ "Helix ->" <> (show h)

main :: forall e.  Eff ( console :: CONSOLE
                       --, exception :: EXCEPTION
                       --, fs :: FS
                       | e) Unit
--main = void $ launchAff do
main = do
  log "FVT Test Suite"
  log "--Test hSlurp"
  testHSlurp
  log "--Test Matrix"
  testMatrix
  log "--Test FVT"
  testFVT

testFVT :: forall e. Eff (console :: CONSOLE | e) Unit
testFVT = do
  let vm = hSlurp tr05129e001412
  let hel = case vm of
              Just v -> helices v
              Nothing -> []
  traverse_ showHelix hel
  traverse_ showMomentum hel
  {-- let l5 = [0,2,3,4,5] -- these are the tracks supposedly from the tau --}
  {-- doFitTest vm l5 --}
  {-- _ <- showProng <<< fitw <<< hFilter l5 <<< vBlowup 10000.0 $ vm --}

testHSlurp :: forall e. Eff (console :: CONSOLE | e) Unit
testHSlurp = do
  log "Test hSlurp dat/tr05129e001412.dat"
  {-- ds <- readTextFile UTF8 "dat/tr05129e001412.dat" --}
  {-- let ws = mapMaybe fromString $ words ds --}
  let ws = tr05129e001412
  log "Test hSlurp dat/tav-4.dat"
  logShow $ mapMaybe fromString $ words tav4
  logShow $ hSlurp tav4
  logShow $ hSlurp ws
  --logShow =<< hSlurp tav4
  let mc = hSlurpMCtruth tav4
  logShow mc

testMatrix :: forall e. Eff (console :: CONSOLE | e) Unit
testMatrix = do
  log $ "Test identity 3"
  logShow $ identity 3
  log $ "Test zero 3 3"
  logShow $ zero_ 3 3
  log "Test Matrix operations: identity == zero?"
  logShow $ (identity 3) == (zero_ 3 3)
  log $ "Test matrix creation"
  let m0 = matrix 3 3 $ \(Tuple i j) -> 2*i - j
  logShow $ Tuple (m0 == (fromList2 3 3 [1,0,-1,3,2,1,5,4,3])) m0
  let m1 = matrix 3 4 $ \(Tuple i j) -> 2*i - j
  logShow $ Tuple (m1 == (fromList2 3 3 [1,0,-1,3,2,1,5,4,3])) m1

  log $ "Test getElem"
  let e1 = getElem 3 4 m1
  logShow $ Tuple (e1 == 2) e1

  log $ "Test fromLists"
  let ll0 :: List (Array Int)
      ll0 = [1,0,0] : [0,2,0] : [0,0,3] : Nil
      ll1 = fromLists ll0
  logShow $ Tuple (ll1 == diagonal 0 [1,2,3]) ll0

  log $ "Test toLists"
  let l0 = diagonal 0 [1,2,3]
      l1 = toLists l0 !! 2
  logShow $ Tuple (l1 == Just [0,0,3]) l1

  log $ "Test arithmetic"
  let m35 = fromLists $ [1,2,3,4,5] : [2,3,4,5,6] : [3,4,5,6,7] : Nil
      m53 = fromLists $ [1,0,0] : [0,1,0] : [0,0,1] : [0,0,0] : [0,0,0] : Nil
      d5n = diagonal 0.0 [2.0, 2.0, 2.0, 2.0, 2.0]
      d5 = diagonal 0 [2, 2, 2, 2, 2]
  logShow $ m35 * m53 == (fromLists $ [1,2,3] : [2,3,4] : [3,4,5] : Nil)
  logShow $ m35 * m53
  logShow $ (diagonal 0 [1,1,1,1,1]) + (diagonal 0 [1,1,1,1,1]) == (diagonal 0 [2,2,2,2,2])
  logShow $ (fromList2 3 3 [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0]) * one
  logShow $ (fromList2 3 3 [1,2,3,4,5,6,7,8,9]) * one
  logShow $ (fromList2 3 3 [0,0,1,0,1,0,1,0,0]) * (fromList2 3 3 [11, 12,13,21,22,23,31,32,33]) * one
  logShow $ (fromList2 3 3 [11, 12,13,21,22,23,31,32,33]) * fromList 3 [-1,1,1]

  log "Test typeShow"
  log $ typeShow
  {-- {1-- (VHMeas _ hl, _) <- hSlurp "dat/tav-0.dat" --1} --}
  {-- {1-- let HMeas _ _ w = head hl --1} --}
  {-- {1-- w `shouldBe` 0.0114 --1} --}

tr05129e001412 :: String
tr05129e001412 = """
   3.355679512023926       3.489715576171875       7.110095977783203
  0.2884106636047363      0.2967556118965149      0.4457152485847473
  0.2967556118965149      0.3057302236557007      0.4589158892631531
  0.4457152485847473      0.4589158892631531      0.7007381319999695
  4.5451703E-03
           6
  9.0513890609145164E-04   1.174186706542969      0.7913663387298584
 -5.4129425436258316E-02   1.309153556823730
  3.0409931517372257E-11  3.0817798313265143E-10 -2.6150961396353978E-09
 -6.2086684238238377E-08  1.9006475560079394E-10  3.0817798313265143E-10
  3.5358195873413933E-06 -5.5664237663677341E-09 -4.7704439509743679E-08
 -3.5389247932471335E-04 -2.6150961396353978E-09 -5.5664237663677341E-09
  3.9334932466772443E-07  9.2603177108685486E-06 -4.2692363422247581E-07
 -6.2086684238238377E-08 -4.7704439509743679E-08  9.2603177108685486E-06
  2.7857377426698804E-04 -1.2511900422396138E-05  1.9006475560079394E-10
 -3.5389247932471335E-04 -4.2692363422247581E-07 -1.2511900422396138E-05
  4.6403184533119202E-02
 -3.2948562875390053E-04  -1.287435531616211       3.964143753051758
 -5.5920504033565521E-02   2.172087669372559
  1.0773015292342425E-11  1.0870629917059116E-11 -9.4798713323740458E-10
 -2.6224558524745589E-08  5.1304871462320989E-10  1.0870629917059116E-11
  1.3991236755828140E-06  6.1739335865951261E-11  3.9363889925425610E-09
 -1.3362320896703750E-04 -9.4798713323740458E-10  6.1739335865951261E-11
  1.0642112613368226E-07  3.0040880574233597E-06 -5.7571856615368233E-08
 -2.6224558524745589E-08  3.9363889925425610E-09  3.0040880574233597E-06
  1.0815335554070771E-04 -1.6780244322944782E-06  5.1304871462320989E-10
 -1.3362320896703750E-04 -5.7571856615368233E-08 -1.6780244322944782E-06
  1.5890464186668396E-02
  8.6099491454660892E-04   1.190025329589844      0.7718949913978577
  -1.004449844360352       4.974927902221680
  7.8076378695612902E-10 -2.4755367200590683E-10 -1.0359136126680824E-07
 -6.7278465394338127E-06  4.4596313841793744E-07 -2.4755367200590683E-10
  6.6328821048955433E-06  2.8732655366070503E-08  1.5816522136447020E-06
 -8.9828821364790201E-04 -1.0359136126680824E-07  2.8732655366070503E-08
  1.3829509043716826E-05  9.0345303760841489E-04 -5.9563441027421504E-05
 -6.7278465394338127E-06  1.5816522136447020E-06  9.0345303760841489E-04
  5.9390719980001450E-02 -3.8860931526869535E-03  4.4596313841793744E-07
 -8.9828821364790201E-04 -5.9563441027421504E-05 -3.8860931526869535E-03
  0.1251238286495209
 -1.7263018526136875E-03   1.039703369140625      0.8659646511077881
  0.2599024176597595       2.128120422363281
  1.5148657328545312E-10 -7.3402152411805588E-11 -1.4714315987873761E-08
 -6.3192055677063763E-07 -3.4522088299127063E-08 -7.3402152411805588E-11
  1.5436929743373184E-06 -5.5447091362736955E-10 -8.1613094948806975E-08
 -1.5131152758840472E-04 -1.4714315987873761E-08 -5.5447091362736955E-10
  1.5367089645224041E-06  6.8635607021860778E-05  4.2090109673154075E-06
 -6.3192055677063763E-07 -8.1613094948806975E-08  6.8635607021860778E-05
  3.2065853010863066E-03  1.9913408323191106E-04 -3.4522088299127063E-08
 -1.5131152758840472E-04  4.2090109673154075E-06  1.9913408323191106E-04
  1.7373077571392059E-02
  1.2108741793781519E-03   1.282915115356445      0.8532057404518127
  8.5045360028743744E-03   1.965600013732910
  3.6512477069594595E-11  8.9357354848829118E-10 -3.3482463468459400E-09
 -8.1875484170268464E-08  9.6036401053822829E-10  8.9357354848829118E-10
  3.0787202831561444E-06 -2.2171841251861224E-08 -2.7003440550288360E-07
 -1.5695679758209735E-04 -3.3482463468459400E-09 -2.2171841251861224E-08
  5.5774097518224153E-07  1.3075616152491421E-05 -4.9851792027766351E-07
 -8.1875484170268464E-08 -2.7003440550288360E-07  1.3075616152491421E-05
  3.5224124439992011E-04 -1.4417236343433615E-05  9.6036401053822829E-10
 -1.5695679758209735E-04 -4.9851792027766351E-07 -1.4417236343433615E-05
  1.7541546374559402E-02
 -7.3608336970210075E-04   1.297574043273926      0.8316786885261536
  -1.011060714721680      -2.867138862609863
  2.0176718074083055E-09  9.1418789205377493E-10 -2.5551665316925209E-07
 -1.5318933947128244E-05 -3.4175937457803229E-07  9.1418789205377493E-10
  7.4829795266850851E-06 -1.1038221003900617E-07 -6.1672653828281909E-06
 -9.3757675494998693E-04 -2.5551665316925209E-07 -1.1038221003900617E-07
  3.2483072573086247E-05  1.9545238465070724E-03  4.3123862269567326E-05
 -1.5318933947128244E-05 -6.1672653828281909E-06  1.9545238465070724E-03
  0.1181144416332245      2.5763250887393951E-03 -3.4175937457803229E-07
 -9.3757675494998693E-04  4.3123862269567326E-05  2.5763250887393951E-03
  0.1227073818445206
"""
tav4 :: String
tav4 = """PU_zpositions:  190 4.06972837448 2.44204807281 7.82136058807 -0.621172726154 -6.80061435699 -1.73116350174 -5.42739343643 -7.10662841797 -6.32562208176 -3.72315001488 1.66695046425 6.55822181702 -7.12538957596 -0.389555871487 -2.8334877491 3.09819436073 -5.65534687042 12.068236351 -1.79448211193 5.73383188248 1.68428444862 2.1804420948 8.66328144073 -12.8040647507 -1.1730145216 -3.57441878319 6.21948480606 -1.26211774349 -3.4871032238 -9.48501300812 -8.33902263641 -1.71619582176 -1.56027853489 1.49686825275 -1.69698286057 1.69038307667 5.10251283646 -2.57128977776 0.749759852886 -2.58463263512 -9.792719841 -8.84095287323 -0.131224393845 -1.56865620613 -5.81232976913 4.21827507019 -4.92665529251 -5.84215211868 -5.74135446548 3.38353490829 -3.13945651054 4.30185222626 -12.6121692657 1.54116880894 1.38944470882 -6.84423398972 2.88845825195 -4.16181087494 6.3093957901 -1.70226609707 3.62256598473 -1.38095474243 1.69552695751 -9.44017601013 2.82410240173 -2.21053552628 2.34878325462 -8.67048835754 1.25067412853 9.49777984619 8.16330623627 -0.870663702488 -4.79498910904 1.78941035271 -7.03154611588 1.68979644775 -0.484967201948 -4.18258905411 0.0788396298885 -4.69477128983 2.32463097572 -2.10498857498 -5.34199571609 3.32180857658 -5.39752531052 -2.84948658943 -2.68618583679 1.0778503418 0.443690419197 -3.29635429382 0.936188876629 -4.41851854324 -3.29131436348 2.12316703796 -10.6452322006 -14.0393047333 3.74121594429 -8.4497051239 -5.68886137009 8.31489753723 -4.49255418777 -7.92309999466 -7.26154613495 -2.43943715096 2.87128973007 -8.41958713531 -5.04697036743 -2.6269865036 -3.01578998566 5.666908741 4.7386713028 4.83959341049 -12.2599534988 6.80844593048 -7.59651374817 1.77152347565 -3.49425053596 4.14569759369 2.39712738991 0.695241510868 0.351206511259 -1.00542604923 -0.592145264149 8.05185890198 1.35937333107 -3.23685288429 1.82836604118 -1.08040130138 -4.06748771667 -1.22976350784 -5.24559354782 4.77764129639 -7.92655897141 6.87241268158 8.90295886993 -10.4462614059 5.51054620743 4.28739690781 -0.413518726826 -2.84266161919 -4.82323074341 -3.47484374046 -6.56179046631 -5.6174902916 2.68036007881 -4.87207984924 -3.47317409515 -1.94823920727 -11.0047950745 -6.04952716827 -12.1523780823 -0.171474739909 1.82068359852 -11.1572389603 -2.97859430313 -3.65392804146 1.67614769936 -4.62239599228 4.72258663177 -3.13622426987 -9.94389533997 -13.6851511002 1.98555517197 4.60026597977 -10.9611978531 -1.63044011593 8.50263690948 -9.76078033447 0.933302462101 6.68330335617 -2.94098043442 -8.59897899628 -0.908704698086 -5.6248884201 -9.19552707672 -6.67034435272 3.34288668633 -2.66896915436 -5.85388660431 -6.08788156509 -9.28157234192 -3.39719057083 -2.08446788788 3.61256814003 4.3055267334 -3.20882606506 -1.37032854557 6.3657708168 -7.99672412872 7.93814659119
0.104794 0.168646 -1.00377 0.0015033299569 0.0 0.0 0.0 0.00151841994375 0.0 0.0 0.0 5.21037006378
1.0
4
-0.450663641447 1.35035226203 1.18063795337 0.0660153061812 -1.23642665653 1.75648085587e-06 1.09397257919e-09 2.97465732046e-07 -4.61079963543e-07 -2.34128183507e-08 1.09397257919e-09 1.44003013247e-06 8.51150190329e-08 2.84054323174e-07 -1.69398772414e-05 2.97465732046e-07 8.51150190329e-08 3.07370719383e-05 -7.83819778007e-05 -3.34401283908e-06 -4.61079963543e-07 2.84054323174e-07 -7.83819778007e-05 0.000201181290322 2.55465602095e-06 -2.34128183507e-08 -1.69398772414e-05 -3.34401283908e-06 2.55465602095e-06 0.000202862953302
0.425837572723 -1.33656916571 -0.200853553729 0.186440212098 0.447653308602 4.94152754982e-06 -1.85234905192e-09 7.72127236814e-07 -1.24222322029e-06 -3.99287580777e-09 -1.85234905192e-09 1.2965380165e-06 1.72925282982e-08 4.64915046905e-07 -1.68021942955e-05 7.72127236814e-07 1.72925282982e-08 2.40928802668e-05 -7.24880374037e-05 -2.46094759859e-06 -1.24222322029e-06 4.64915046905e-07 -7.24880374037e-05 0.000219607783947 7.73318163283e-07 -3.99287580777e-09 -1.68021942955e-05 -2.46094759859e-06 7.73318163283e-07 0.000218317465624
0.292514034965 1.39665579944 -0.993975573833 0.141543926193 0.40182813437 6.18352771653e-07 2.45095588269e-09 2.34424803125e-07 -8.39045242174e-07 -8.35598825688e-08 2.45095588269e-09 8.66051891535e-07 4.61750582215e-10 -3.98558910319e-07 -1.4314922737e-05 2.34424803125e-07 4.61750582215e-10 2.8809732612e-05 -8.27241237857e-05 2.18257969209e-06 -8.39045242174e-07 -3.98558910319e-07 -8.27241237857e-05 0.000238582899328 4.61562564169e-07 -8.35598825688e-08 -1.4314922737e-05 2.18257969209e-06 4.61562564169e-07 0.000236972875427
-0.29652562498 1.37864870921 -1.02387889924 0.192178996941 0.0749212341852 1.4916007558e-06 5.99006577673e-09 7.09483913397e-07 -2.9230166092e-06 -3.92529898363e-07 5.99006577673e-09 7.67293840909e-07 5.73736658183e-09 2.58630308281e-07 -1.14107451736e-05 7.09483913397e-07 5.73736658183e-09 2.14707033592e-05 -6.15742173977e-05 -1.75877414677e-06 -2.9230166092e-06 2.58630308281e-07 -6.15742173977e-05 0.000178089467227 1.27894770685e-06 -3.92529898363e-07 -1.14107451736e-05 -1.75877414677e-06 1.27894770685e-06 0.000170099316165
"""


Docs

Docs

Original commit a7657ef3e1d615e0cc368ad02c71c3b5e35b89db

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)

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

renderFromJsonString :: Pipeline String
renderFromJsonString = relax $ firstSuccess (pipelines Env.current)


Display history of all previous evaluations

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Data.Either
import Data.Maybe
import Data.Foldable (for_)
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff = Eff (dom :: DOM, trace :: Trace)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  void $ runStateT showEvaluationState { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = hists } <- get :: EvalM EvalState

  liftEff $ exprToJQuery expr >>= flip J.append output
  liftEff $ showHistory hists history

  liftEff (J.find ".binary, .app, .func" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

showHistory :: [Expr] -> J.JQuery -> DOMEff Unit
showHistory exprs jq = for_ exprs $ \expr -> do
  exprToJQuery expr >>= flip J.append jq
  J.create "

" >>= flip J.append jq
  return unit

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  container <- J.select ("#" ++ name ++ "-container") >>= J.clear
  content <- J.create "

" >>= J.addClass name
  J.append content container
  return content

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Nothing -> return unit
      Just _  -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOve"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Data.Either
import Data.Maybe
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff = Eff (dom :: DOM, trace :: Trace)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  void $ runStateT showEvaluationState { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showEvaluationState :: EvalM Unit
showEvaluationState = do
  outputContainer <- liftEff $ J.select "#output-container"
  liftEff $ J.clear outputContainer

  output <- liftEff $ J.create "

" >>= J.addClass "output"
  liftEff $ J.append output outputContainer

  { env = env, expr = expr } <- get :: EvalM EvalState

  jexpr <- liftEff $ exprToJQuery expr
  liftEff $ J.append jexpr output

  liftEff (J.find ".binary, .app, .func" output) >>= makeClickable
  liftEff (J.find ".clickable" output) >>= addMouseOverListener >>= addClickListener
  liftEff $ J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver)

  liftEff $ return unit :: DOMEff Unit

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Nothing -> return unit
      Just _  -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOve"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      modify (\es -> es { expr = expr' })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq


Add correct starting point.

Add correct starting point.

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import Global
import qualified Lookangle as L
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  --setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 40.371975 (-83.060578)
  roadmap <- gMap mapE (MapOptions { zoom: 10, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://mv-ws1.noexc.org:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> handleEvent x mvcA polyline marker roadmap)
  --sendWS socket example

  where
    handleEvent e mvcA polyline marker roadmap = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker roadmap result.coordinates
          updateLookangle result.coordinates result.altitude
          updateTimestamp result.time
          updateTemperature result.temperature
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker roadmap) coordinates

updateTemperature ::
  forall eff.
  Celsius
  -> Eff (dom :: DOM | eff) Unit
updateTemperature temp = do
  doc <- document globalWindow
  Just tempField <- getElementById "temperature" doc
  setInnerHTML (show temp) tempField

updateTimestamp ::
  forall eff.
  String
  -> Eff (dom :: DOM, now :: MomentJS.Now | eff) Unit
updateTimestamp time = do
  doc <- document globalWindow
  --nowMoment <- now
  --let last = createMoment (momentConstructor time)
  Just lastupdate <- getElementById "lastupdate" doc
  --let str = liftMoment2 momentFrom nowMoment <$> last
  --let humanReadableTime = fromMaybe "Unknown" str
  setInnerHTML time lastupdate

addToPath ::
  forall eff.
  MVCArray LatLng
  -> Polyline
  -> Marker
  -> Map
  -> Coordinate
  -> Eff eff Unit
addToPath mvcA polyline marker roadmap (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng
  panTo roadmap latestLatLng

updateLookangle ::
  forall eff a.
  Coordinate
  -> Number
  -> Eff (dom :: DOM | eff) Unit
updateLookangle (Coordinate c) altitude = do
  doc <- document globalWindow
  Just lookangle <- getElementById "lookangle" doc
  Just fLat' <- getElementById "f_lat" doc
  Just fLon' <- getElementById "f_lon" doc
  Just fAlt' <- getElementById "f_alt" doc
  fLat <- readFloat <$> value fLat'
  fLon <- readFloat <$> value fLon'
  fAlt <- readFloat <$> value fAlt'
  let angle = L.lookAngle
              (L.Coordinate fLat fLon fAlt)
              (L.Coordinate c.latitude c.longitude altitude)
  setInnerHTML (show angle) lookangle

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import Global
import qualified Lookangle as L
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  --setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 10, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://mv-ws1.noexc.org:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> handleEvent x mvcA polyline marker roadmap)
  --sendWS socket example

  where
    handleEvent e mvcA polyline marker roadmap = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker roadmap result.coordinates
          updateLookangle result.coordinates result.altitude
          updateTimestamp result.time
          updateTemperature result.temperature
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker roadmap) coordinates

updateTemperature ::
  forall eff.
  Celsius
  -> Eff (dom :: DOM | eff) Unit
updateTemperature temp = do
  doc <- document globalWindow
  Just tempField <- getElementById "temperature" doc
  setInnerHTML (show temp) tempField

updateTimestamp ::
  forall eff.
  String
  -> Eff (dom :: DOM, now :: MomentJS.Now | eff) Unit
updateTimestamp time = do
  doc <- document globalWindow
  --nowMoment <- now
  --let last = createMoment (momentConstructor time)
  Just lastupdate <- getElementById "lastupdate" doc
  --let str = liftMoment2 momentFrom nowMoment <$> last
  --let humanReadableTime = fromMaybe "Unknown" str
  setInnerHTML time lastupdate

addToPath ::
  forall eff.
  MVCArray LatLng
  -> Polyline
  -> Marker
  -> Map
  -> Coordinate
  -> Eff eff Unit
addToPath mvcA polyline marker roadmap (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng
  panTo roadmap latestLatLng

updateLookangle ::
  forall eff a.
  Coordinate
  -> Number
  -> Eff (dom :: DOM | eff) Unit
updateLookangle (Coordinate c) altitude = do
  doc <- document globalWindow
  Just lookangle <- getElementById "lookangle" doc
  Just fLat' <- getElementById "f_lat" doc
  Just fLon' <- getElementById "f_lon" doc
  Just fAlt' <- getElementById "f_alt" doc
  fLat <- readFloat <$> value fLat'
  fLon <- readFloat <$> value fLon'
  fAlt <- readFloat <$> value fAlt'
  let angle = L.lookAngle
              (L.Coordinate fLat fLon fAlt)
              (L.Coordinate c.latitude c.longitude altitude)
  setInnerHTML (show angle) lookangle


refactoring

refactoring

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, hour, minute, second, time, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Time.Duration (Minutes)

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

type Duration = { days :: Int, hours :: Int, minutes :: Int, seconds :: Int }

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe Duration)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend dateTime =
    let dayOfWeek = fromEnum $ weekday $ date dateTime
        hourOfDay = fromEnum $ hour    $ time dateTime
        minutes   = fromEnum $ minute  $ time dateTime
        seconds   = fromEnum $ second  $ time dateTime
    in if dayOfWeek > 5 then Nothing else if hourOfDay > 16 then Nothing else Just { days: 5 - dayOfWeek, hours: 0, minutes: 0, seconds: 0 }

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, Weekday(..), adjust, date, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (Either(..), either)
import Data.Formatter.DateTime (formatDateTime)
import Data.Maybe (Maybe, fromMaybe)
import Data.Time.Duration (Minutes)

nowAsDateTime :: forall eff. Eff (now :: NOW | eff) DateTime
nowAsDateTime = map toDateTime now

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) (Maybe DateTime)
currentLocalTime = lift2 adjust offset nowAsDateTime

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString maybeTime = let workaroundForWeekday = (map (\dateTime -> show $ weekday $ date dateTime) >>> fromMaybe "ERROR") maybeTime
                           formattedDate = (map (formatDateTime "HH:mm") >>> fromMaybe (Left "ERROR") >>> (either (const "ERROR") id)) maybeTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map (date >>> weekday >>> weekendDay) nowAsDateTime
  where
  weekendDay Saturday = true
  weekendDay Sunday   = true
  weekendDay _        = false


consistency: 'type class' with a space

consistency: 'type class' with a space

module Control.Plus where

import Control.Alt

-- | The `Plus` type class extends the `Alt` type class with a value that
-- | should be the left and right identity for `(<|>)`.
-- |
-- | `Plus` instances should satisfy the following laws:
-- |
-- | - Left identity: `empty <|> x == x`
-- | - Right identity: `x <|> empty == x`
class (Alt f) <= Plus f where
  empty :: forall a. f a

module Control.Plus where

import Control.Alt

-- | The `Plus` type class extends the `Alt` typeclass with a value that
-- | should be the left and right identity for `(<|>)`.
-- |
-- | `Plus` instances should satisfy the following laws:
-- |
-- | - Left identity: `empty <|> x == x`
-- | - Right identity: `x <|> empty == x`
class (Alt f) <= Plus f where
  empty :: forall a. f a


changed function name "same" to "sameLine"

module IndentParser (
    -- $doc
    -- * Types
    IndentParser, runIndent,
    -- * Blocks
    withBlock, withBlock', block,
    -- * Indentation Checking
    indented, sameLine, sameOrIndented, checkIndent, withPos,
    -- * Paired characters
    -- indentBrackets, indentAngles, indentBraces, indentParens,
    -- * Line Fold Chaining
    -- | Any chain using these combinators must used with 'withPos'
    indentAp, (<+/>), indentNoAp, (<-/>), indentMany, (<*/>), indentOp, (<?/>), Optional(..)
) where

import Prelude (class Monad, Unit, id, ap, const, ($), flip, unit, return, (==), bind, (<=))
import Data.List (List(..), many)
import Data.Maybe (Maybe(..))

import Control.Alt ((<|>))
import Control.Apply ((*>), lift2)
import Control.Monad.Trans (lift)
import Control.Monad.State (State, evalState)
import Control.Monad.State.Trans (get, put)
import Data.Either (Either(..))

import Text.Parsing.Parser (ParseError, ParserT(..), PState(..), fail)
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.Pos (Position(..), initialPos)
import Text.Parsing.Parser.String (string, oneOf)

-- $doc
-- This is purescript-port of Text.Parsing.Indent
-- https://hackage.haskell.org/package/indents-0.3.3/docs/Text-Parsec-Indent.html, 05.07.2016

-- A module to construct indentation aware parsers. Many programming
-- language have indentation based syntax rules e.g. python and Haskell.
-- This module exports combinators to create such parsers.
--
-- The input source can be thought of as a list of tokens. Abstractly
-- each token occurs at a line and a column and has a width. The column
-- number of a token measures is indentation. If t1 and t2 are two tokens
-- then we say that indentation of t1 is more than t2 if the column
-- number of occurrence of t1 is greater than that of t2.
--
-- Currently this module supports two kind of indentation based syntactic
-- structures which we now describe:
--
-- [Block] --A block of indentation /c/ is a sequence of tokens with
-- indentation at least /c/.  Examples for a block is a where clause of
-- Haskell with no explicit braces.
--
-- [Line fold] A line fold starting at line /l/ and indentation /c/ is a
-- sequence of tokens that start at line /l/ and possibly continue to
-- subsequent lines as long as the indentation is greater than /c/. Such
-- a sequence of lines need to be /folded/ to a single line. An example
-- is MIME headers. Line folding based binding separation is used in
-- Haskell as well.

-- | Indentation sensitive parser type. Usually @ m @ will
--   be @ Identity @ as with any @ ParserT @
type IndentParser s a = ParserT s (State Position) a

-- | @ getPosition @ returns current position
--   should probably be added to Text.Parsing.Parser.Pos
getPosition :: forall m s. (Monad m) => ParserT s m Position
getPosition = ParserT $ \(PState { input: (i :: s), position: (pos :: Position)}) -> return {input: (i :: s), result: (Right (pos :: Position)) :: Either ParseError Position, consumed: false, position: (pos :: Position)}

-- | simple helper function to avoid typ-problems with MonadState instance
get' :: forall s. IndentParser s Position
get' = do
  g <- lift get
  return g

-- | simple helper function to avoid typ-problems with MonadState instance
put' :: forall s. Position -> IndentParser s Unit
put' p = lift (put p)

sourceColumn :: Position -> Int
sourceColumn (Position {line: _, column: c}) = c

sourceLine :: Position -> Int
sourceLine (Position {line: l, column: _}) = l

setSourceLine :: Position -> Int -> Position
setSourceLine (Position {line: _, column: c}) l = Position {line: l, column: c}

biAp :: forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
biAp f c v1 v2 = c (f v1) (f v2)

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

symbol :: forall m. (Monad m) => String -> ParserT String m String
symbol name = (many $ oneOf [' ','\t']) *> (string name)

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

-- | @ 'withBlock' f a p @ parses @ a @
--   followed by an indented block of @ p @
--   combining them with @ f @
withBlock :: forall a b c s. (a -> List b -> c) -> IndentParser s a -> IndentParser s b -> IndentParser s c
withBlock f a p = withPos $ do
    r1 <- a
    r  <- optionMaybe $ indented *> block p
    case r of
      Nothing -> return (f r1 Nil)
      Just r2 -> return (f r1 r2)

-- | Like 'withBlock', but throws away initial parse result
withBlock' :: forall a b s. IndentParser s a -> IndentParser s b -> IndentParser s (List b)
withBlock' = withBlock (flip const)

-- | Parses only when indented past the level of the reference
indented :: forall s. IndentParser s Unit
indented = do
    pos <- getPosition
    s <- get'
    if biAp sourceColumn (<=) pos s then fail "not indented" else do
        put' $ setSourceLine s (sourceLine pos)
        return unit

-- | Parses only when indented past the level of the reference or on the same line
sameOrIndented :: forall s. IndentParser s Unit
sameOrIndented = sameLine <|> indented

-- | Parses only on the same line as the reference
sameLine :: forall s. IndentParser s Unit
sameLine = do
    pos <- getPosition
    s   <- get'
    if biAp sourceLine (==) pos s then return unit else fail "over one line"

-- | Parses a block of lines at the same indentation level
block :: forall s a. IndentParser s a -> IndentParser s (List a)
block p = withPos $ do
    r <- many1 $ checkIndent *> p
    return r

-- | Parses using the current location for indentation reference
withPos :: forall s a. IndentParser s a -> IndentParser s a
withPos x = do
    a <- get'
    p <- getPosition
    r <- put' p *> x
    put' a *> return r

-- | Ensures the current indentation level matches that of the reference
checkIndent :: forall s. IndentParser s Unit
checkIndent = do
    s <- get'
    p <- getPosition
    if biAp sourceColumn (==) p s then return unit else fail "indentation doesn't match"

-- | Run the result of an indentation sensitive parse
runIndent :: forall a. State Position a -> a
runIndent = flip evalState initialPos

-- | '<+/>' is to indentation sensitive parsers what 'ap' is to monads
indentAp :: forall s a b. IndentParser s (a -> b) -> IndentParser s a -> IndentParser s b
indentAp a b = ap a $ sameOrIndented *> b

infixl 9 indentAp as <+/>

-- | Like '<+/>' but doesn't apply the function to the parsed value
indentNoAp :: forall s a b. IndentParser s a -> IndentParser s b -> IndentParser s a
indentNoAp a b = lift2 const a $ sameOrIndented *> b

infixl 10 indentNoAp as <-/>

-- | Like '<+/>' but applies the second parser many times
indentMany :: forall s a b. IndentParser s (List a -> b) -> IndentParser s a -> IndentParser s b
indentMany a b = ap a (many (sameOrIndented *> b))

infixl 11 indentMany as <*/>

-- | Datatype used to optional parsing
data Optional s a = Opt a (IndentParser s a)

-- | Like '<+/>' but applies the second parser optionally using the 'Optional' datatype
indentOp :: forall s a b. IndentParser s (a -> b) -> (Optional s a) -> IndentParser s b
indentOp a (Opt b c) = ap a (option b (sameOrIndented *> c))

infixl 12 indentOp as <?/>

-- | parses with surrounding brackets
indentBrackets :: forall a. IndentParser String a -> IndentParser String a
indentBrackets p = withPos $ return id <-/> symbol "[" <+/> p <-/> symbol "]"

-- | parses with surrounding angle brackets
indentAngles :: forall a. IndentParser String a -> IndentParser String a
indentAngles p = withPos $ return id <-/> symbol "<" <+/> p <-/> symbol ">"

-- | parses with surrounding braces
indentBraces :: forall a. IndentParser String a -> IndentParser String a
indentBraces p = withPos $ return id <-/> symbol "{" <+/> p <-/> symbol "}"

-- | parses with surrounding parentheses
indentParens :: forall a. IndentParser String a -> IndentParser String a
indentParens p = withPos $ return id <-/> symbol "(" <+/> p <-/> symbol ")"

module IndentParser (
    -- $doc
    -- * Types
    IndentParser, runIndent,
    -- * Blocks
    withBlock, withBlock', block,
    -- * Indentation Checking
    indented, same, sameOrIndented, checkIndent, withPos,
    -- * Paired characters
    -- indentBrackets, indentAngles, indentBraces, indentParens,
    -- * Line Fold Chaining
    -- | Any chain using these combinators must used with 'withPos'
    indentAp, (<+/>), indentNoAp, (<-/>), indentMany, (<*/>), indentOp, (<?/>), Optional(..)
) where

import Prelude (class Monad, Unit, id, ap, const, ($), flip, unit, return, (==), bind, (<=))
import Data.List (List(..), many)
import Data.Maybe (Maybe(..))

import Control.Alt ((<|>))
import Control.Apply ((*>), lift2)
import Control.Monad.Trans (lift)
import Control.Monad.State (State, evalState)
import Control.Monad.State.Trans (get, put)
import Data.Either (Either(..))

import Text.Parsing.Parser (ParseError, ParserT(..), PState(..), fail)
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.Pos (Position(..), initialPos)
import Text.Parsing.Parser.String (string, oneOf)

-- $doc
-- This is purescript-port of Text.Parsing.Indent
-- https://hackage.haskell.org/package/indents-0.3.3/docs/Text-Parsec-Indent.html, 05.07.2016

-- A module to construct indentation aware parsers. Many programming
-- language have indentation based syntax rules e.g. python and Haskell.
-- This module exports combinators to create such parsers.
--
-- The input source can be thought of as a list of tokens. Abstractly
-- each token occurs at a line and a column and has a width. The column
-- number of a token measures is indentation. If t1 and t2 are two tokens
-- then we say that indentation of t1 is more than t2 if the column
-- number of occurrence of t1 is greater than that of t2.
--
-- Currently this module supports two kind of indentation based syntactic
-- structures which we now describe:
--
-- [Block] --A block of indentation /c/ is a sequence of tokens with
-- indentation at least /c/.  Examples for a block is a where clause of
-- Haskell with no explicit braces.
--
-- [Line fold] A line fold starting at line /l/ and indentation /c/ is a
-- sequence of tokens that start at line /l/ and possibly continue to
-- subsequent lines as long as the indentation is greater than /c/. Such
-- a sequence of lines need to be /folded/ to a single line. An example
-- is MIME headers. Line folding based binding separation is used in
-- Haskell as well.

-- | Indentation sensitive parser type. Usually @ m @ will
--   be @ Identity @ as with any @ ParserT @
type IndentParser s a = ParserT s (State Position) a

-- | @ getPosition @ returns current position
--   should probably be added to Text.Parsing.Parser.Pos
getPosition :: forall m s. (Monad m) => ParserT s m Position
getPosition = ParserT $ \(PState { input: (i :: s), position: (pos :: Position)}) -> return {input: (i :: s), result: (Right (pos :: Position)) :: Either ParseError Position, consumed: false, position: (pos :: Position)}

-- | simple helper function to avoid typ-problems with MonadState instance
get' :: forall s. IndentParser s Position
get' = do
  g <- lift get
  return g

-- | simple helper function to avoid typ-problems with MonadState instance
put' :: forall s. Position -> IndentParser s Unit
put' p = lift (put p)

sourceColumn :: Position -> Int
sourceColumn (Position {line: _, column: c}) = c

sourceLine :: Position -> Int
sourceLine (Position {line: l, column: _}) = l

setSourceLine :: Position -> Int -> Position
setSourceLine (Position {line: _, column: c}) l = Position {line: l, column: c}

biAp :: forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
biAp f c v1 v2 = c (f v1) (f v2)

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

symbol :: forall m. (Monad m) => String -> ParserT String m String
symbol name = (many $ oneOf [' ','\t']) *> (string name)

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

-- | @ 'withBlock' f a p @ parses @ a @
--   followed by an indented block of @ p @
--   combining them with @ f @
withBlock :: forall a b c s. (a -> List b -> c) -> IndentParser s a -> IndentParser s b -> IndentParser s c
withBlock f a p = withPos $ do
    r1 <- a
    r  <- optionMaybe $ indented *> block p
    case r of
      Nothing -> return (f r1 Nil)
      Just r2 -> return (f r1 r2)

-- | Like 'withBlock', but throws away initial parse result
withBlock' :: forall a b s. IndentParser s a -> IndentParser s b -> IndentParser s (List b)
withBlock' = withBlock (flip const)

-- | Parses only when indented past the level of the reference
indented :: forall s. IndentParser s Unit
indented = do
    pos <- getPosition
    s <- get'
    if biAp sourceColumn (<=) pos s then fail "not indented" else do
        put' $ setSourceLine s (sourceLine pos)
        return unit

-- | Parses only when indented past the level of the reference or on the same line
sameOrIndented :: forall s. IndentParser s Unit
sameOrIndented = same <|> indented

-- | Parses only on the same line as the reference
same :: forall s. IndentParser s Unit
same = do
    pos <- getPosition
    s   <- get'
    if biAp sourceLine (==) pos s then return unit else fail "over one line"

-- | Parses a block of lines at the same indentation level
block :: forall s a. IndentParser s a -> IndentParser s (List a)
block p = withPos $ do
    r <- many1 $ checkIndent *> p
    return r

-- | Parses using the current location for indentation reference
withPos :: forall s a. IndentParser s a -> IndentParser s a
withPos x = do
    a <- get'
    p <- getPosition
    r <- put' p *> x
    put' a *> return r

-- | Ensures the current indentation level matches that of the reference
checkIndent :: forall s. IndentParser s Unit
checkIndent = do
    s <- get'
    p <- getPosition
    if biAp sourceColumn (==) p s then return unit else fail "indentation doesn't match"

-- | Run the result of an indentation sensitive parse
runIndent :: forall a. State Position a -> a
runIndent = flip evalState initialPos

-- | '<+/>' is to indentation sensitive parsers what 'ap' is to monads
indentAp :: forall s a b. IndentParser s (a -> b) -> IndentParser s a -> IndentParser s b
indentAp a b = ap a $ sameOrIndented *> b

infixl 9 indentAp as <+/>

-- | Like '<+/>' but doesn't apply the function to the parsed value
indentNoAp :: forall s a b. IndentParser s a -> IndentParser s b -> IndentParser s a
indentNoAp a b = lift2 const a $ sameOrIndented *> b

infixl 10 indentNoAp as <-/>

-- | Like '<+/>' but applies the second parser many times
indentMany :: forall s a b. IndentParser s (List a -> b) -> IndentParser s a -> IndentParser s b
indentMany a b = ap a (many (sameOrIndented *> b))

infixl 11 indentMany as <*/>

-- | Datatype used to optional parsing
data Optional s a = Opt a (IndentParser s a)

-- | Like '<+/>' but applies the second parser optionally using the 'Optional' datatype
indentOp :: forall s a b. IndentParser s (a -> b) -> (Optional s a) -> IndentParser s b
indentOp a (Opt b c) = ap a (option b (sameOrIndented *> c))

infixl 12 indentOp as <?/>

-- | parses with surrounding brackets
indentBrackets :: forall a. IndentParser String a -> IndentParser String a
indentBrackets p = withPos $ return id <-/> symbol "[" <+/> p <-/> symbol "]"

-- | parses with surrounding angle brackets
indentAngles :: forall a. IndentParser String a -> IndentParser String a
indentAngles p = withPos $ return id <-/> symbol "<" <+/> p <-/> symbol ">"

-- | parses with surrounding braces
indentBraces :: forall a. IndentParser String a -> IndentParser String a
indentBraces p = withPos $ return id <-/> symbol "{" <+/> p <-/> symbol "}"

-- | parses with surrounding parentheses
indentParens :: forall a. IndentParser String a -> IndentParser String a
indentParens p = withPos $ return id <-/> symbol "(" <+/> p <-/> symbol ")"


Lazy instance for RWST

Lazy instance for RWST

-- | This module defines the reader-writer-state monad transformer, `RWST`.

module Control.Monad.RWS.Trans
  ( RWSResult(..)
  , RWST(..), runRWST, evalRWST, execRWST, mapRWST, withRWST
  , module Control.Monad.Trans.Class
  ) where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.Reader.Class (class MonadAsk, class MonadReader)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.Monad.Writer.Class (class MonadWriter, class MonadTell)
import Control.Plus (class Plus, empty)

import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), uncurry)

data RWSResult state result writer = RWSResult state result writer

-- | The reader-writer-state monad transformer, which combines the operations
-- | of `RWST`, `WriterT` and `StateT` into a single monad transformer.
newtype RWST r w s m a = RWST (r -> s -> m (RWSResult s a w))

-- | Run a computation in the `RWST` monad.
runRWST :: forall r w s m a. RWST r w s m a -> r -> s -> m (RWSResult s a w)
runRWST (RWST x) = x

-- | Run a computation in the `RWST` monad, discarding the final state.
evalRWST :: forall r w s m a. Monad m => RWST r w s m a -> r -> s -> m (Tuple a w)
evalRWST (RWST m) r s = m r s >>= \(RWSResult _ result writer) -> pure (Tuple result writer)

-- | Run a computation in the `RWST` monad, discarding the result.
execRWST :: forall r w s m a. Monad m => RWST r w s m a -> r -> s -> m (Tuple s w)
execRWST (RWST m) r s = m r s >>= \(RWSResult state _ writer) -> pure (Tuple state writer)

-- | Change the result and accumulator types in a `RWST` monad action.
mapRWST :: forall r w1 w2 s m1 m2 a1 a2. (m1 (RWSResult s a1 w1) -> m2 (RWSResult s a2 w2)) -> RWST r w1 s m1 a1 -> RWST r w2 s m2 a2
mapRWST f (RWST m) = RWST \r s -> f (m r s)

-- | Change the context type in a `RWST` monad action.
withRWST :: forall r1 r2 w s m a. (r2 -> s -> Tuple r1 s) -> RWST r1 w s m a -> RWST r2 w s m a
withRWST f m = RWST \r s -> uncurry (case m of RWST m' -> m') (f r s)

derive instance newtypeRWST :: Newtype (RWST r w s m a) _

instance functorRWST :: (Functor m) => Functor (RWST r w s m) where
  map f (RWST m) = RWST \r s ->
    (\(RWSResult state result writer) -> RWSResult state (f result) writer) <$> m r s

instance applyRWST :: (Bind m, Monoid w) => Apply (RWST r w s m) where
  apply (RWST f) (RWST m) = RWST \r s ->
    f r s >>= \(RWSResult s' f' w') ->
    m r s' <#> \(RWSResult s'' a'' w'') ->
    RWSResult s'' (f' a'') (w' <> w'')

instance altRWST :: Alt m => Alt (RWST r w s m) where
  alt (RWST m) (RWST n) = RWST $ \ r s -> m r s <|> n r s

instance alternativeRWST :: (Monoid w, Alternative m, Monad m) => Alternative (RWST r w s m)

instance bindRWST :: (Bind m, Monoid w) => Bind (RWST r w s m) where
  bind (RWST m) f = RWST \r s ->
    m r s >>= \(RWSResult s' a w) ->
      case (f a) of
        RWST f' -> f' r s' <#> \(RWSResult state result writer) ->
          RWSResult state result (w <> writer)

instance applicativeRWST :: (Monad m, Monoid w) => Applicative (RWST r w s m) where
  pure a = RWST \_ s -> pure $ RWSResult s a mempty

instance monadRWST :: (Monad m, Monoid w) => Monad (RWST r w s m)

instance monadTransRWST :: Monoid w => MonadTrans (RWST r w s) where
  lift m = RWST \_ s -> m >>= \a -> pure $ RWSResult s a mempty

instance lazyRWST :: Lazy (RWST r w s m a) where
  defer f = RWST \r s -> case f unit of RWST f' -> f' r s

instance monadEffRWS :: (Monoid w, MonadEff eff m) => MonadEff eff (RWST r w s m) where
  liftEff = lift <<< liftEff

instance monadAskRWST :: (Monad m, Monoid w) => MonadAsk r (RWST r w s m) where
  ask = RWST \r s -> pure $ RWSResult s r mempty

instance monadReaderRWST :: (Monad m, Monoid w) => MonadReader r (RWST r w s m) where
  local f m = RWST \r s -> case m of RWST m' -> m' (f r) s

instance monadStateRWST :: (Monad m, Monoid w) => MonadState s (RWST r w s m) where
  state f = RWST \_ s -> case f s of Tuple a s' -> pure $ RWSResult s' a mempty

instance monadTellRWST :: (Monad m, Monoid w) => MonadTell w (RWST r w s m) where
  tell w = RWST \_ s -> pure $ RWSResult s unit w

instance monadWriterRWST :: (Monad m, Monoid w) => MonadWriter w (RWST r w s m) where
  listen m = RWST \r s ->
    case m of RWST m' ->
      m' r s >>= \(RWSResult s' a w) ->
        pure $ RWSResult s' (Tuple a w) w
  pass m = RWST \r s ->
    case m of RWST m' ->
      m' r s >>= \(RWSResult s' (Tuple a f) w) ->
        pure $ RWSResult s' a (f w)

instance monadErrorRWST :: (MonadError e m, Monoid w) => MonadError e (RWST r w s m) where
  throwError e = lift (throwError e)
  catchError m h = RWST $ \r s ->
    catchError
      (case m of RWST m' -> m' r s)
      (\e -> case h e of RWST m' -> m' r s)

instance monadRecRWST :: (MonadRec m, Monoid w) => MonadRec (RWST r w s m) where
  tailRecM k a = RWST \r s -> tailRecM (k' r) (RWSResult s a mempty)
    where
    k' r (RWSResult state result writer) =
      case k result of
        RWST m -> do
          RWSResult state' result' writer' <- m r state
          pure case result' of
            Loop x -> Loop (RWSResult state' x (writer <> writer'))
            Done y -> Done (RWSResult state' y (writer <> writer'))

instance plusRWST :: Plus m => Plus (RWST r w s m) where
  empty = RWST \ _ _ -> empty

-- | This module defines the reader-writer-state monad transformer, `RWST`.

module Control.Monad.RWS.Trans
  ( RWSResult(..)
  , RWST(..), runRWST, evalRWST, execRWST, mapRWST, withRWST
  , module Control.Monad.Trans.Class
  ) where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.Reader.Class (class MonadAsk, class MonadReader)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.Monad.Writer.Class (class MonadWriter, class MonadTell)
import Control.Plus (class Plus, empty)

import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), uncurry)

data RWSResult state result writer = RWSResult state result writer

-- | The reader-writer-state monad transformer, which combines the operations
-- | of `RWST`, `WriterT` and `StateT` into a single monad transformer.
newtype RWST r w s m a = RWST (r -> s -> m (RWSResult s a w))

-- | Run a computation in the `RWST` monad.
runRWST :: forall r w s m a. RWST r w s m a -> r -> s -> m (RWSResult s a w)
runRWST (RWST x) = x

-- | Run a computation in the `RWST` monad, discarding the final state.
evalRWST :: forall r w s m a. Monad m => RWST r w s m a -> r -> s -> m (Tuple a w)
evalRWST (RWST m) r s = m r s >>= \(RWSResult _ result writer) -> pure (Tuple result writer)

-- | Run a computation in the `RWST` monad, discarding the result.
execRWST :: forall r w s m a. Monad m => RWST r w s m a -> r -> s -> m (Tuple s w)
execRWST (RWST m) r s = m r s >>= \(RWSResult state _ writer) -> pure (Tuple state writer)

-- | Change the result and accumulator types in a `RWST` monad action.
mapRWST :: forall r w1 w2 s m1 m2 a1 a2. (m1 (RWSResult s a1 w1) -> m2 (RWSResult s a2 w2)) -> RWST r w1 s m1 a1 -> RWST r w2 s m2 a2
mapRWST f (RWST m) = RWST \r s -> f (m r s)

-- | Change the context type in a `RWST` monad action.
withRWST :: forall r1 r2 w s m a. (r2 -> s -> Tuple r1 s) -> RWST r1 w s m a -> RWST r2 w s m a
withRWST f m = RWST \r s -> uncurry (case m of RWST m' -> m') (f r s)

derive instance newtypeRWST :: Newtype (RWST r w s m a) _

instance functorRWST :: (Functor m) => Functor (RWST r w s m) where
  map f (RWST m) = RWST \r s ->
    (\(RWSResult state result writer) -> RWSResult state (f result) writer) <$> m r s

instance applyRWST :: (Bind m, Monoid w) => Apply (RWST r w s m) where
  apply (RWST f) (RWST m) = RWST \r s ->
    f r s >>= \(RWSResult s' f' w') ->
    m r s' <#> \(RWSResult s'' a'' w'') ->
    RWSResult s'' (f' a'') (w' <> w'')

instance altRWST :: Alt m => Alt (RWST r w s m) where
  alt (RWST m) (RWST n) = RWST $ \ r s -> m r s <|> n r s

instance alternativeRWST :: (Monoid w, Alternative m, Monad m) => Alternative (RWST r w s m)

instance bindRWST :: (Bind m, Monoid w) => Bind (RWST r w s m) where
  bind (RWST m) f = RWST \r s ->
    m r s >>= \(RWSResult s' a w) ->
      case (f a) of
        RWST f' -> f' r s' <#> \(RWSResult state result writer) ->
          RWSResult state result (w <> writer)

instance applicativeRWST :: (Monad m, Monoid w) => Applicative (RWST r w s m) where
  pure a = RWST \_ s -> pure $ RWSResult s a mempty

instance monadRWST :: (Monad m, Monoid w) => Monad (RWST r w s m)

instance monadTransRWST :: Monoid w => MonadTrans (RWST r w s) where
  lift m = RWST \_ s -> m >>= \a -> pure $ RWSResult s a mempty

instance monadEffRWS :: (Monoid w, MonadEff eff m) => MonadEff eff (RWST r w s m) where
  liftEff = lift <<< liftEff

instance monadAskRWST :: (Monad m, Monoid w) => MonadAsk r (RWST r w s m) where
  ask = RWST \r s -> pure $ RWSResult s r mempty

instance monadReaderRWST :: (Monad m, Monoid w) => MonadReader r (RWST r w s m) where
  local f m = RWST \r s -> case m of RWST m' -> m' (f r) s

instance monadStateRWST :: (Monad m, Monoid w) => MonadState s (RWST r w s m) where
  state f = RWST \_ s -> case f s of Tuple a s' -> pure $ RWSResult s' a mempty

instance monadTellRWST :: (Monad m, Monoid w) => MonadTell w (RWST r w s m) where
  tell w = RWST \_ s -> pure $ RWSResult s unit w

instance monadWriterRWST :: (Monad m, Monoid w) => MonadWriter w (RWST r w s m) where
  listen m = RWST \r s ->
    case m of RWST m' ->
      m' r s >>= \(RWSResult s' a w) ->
        pure $ RWSResult s' (Tuple a w) w
  pass m = RWST \r s ->
    case m of RWST m' ->
      m' r s >>= \(RWSResult s' (Tuple a f) w) ->
        pure $ RWSResult s' a (f w)

instance monadErrorRWST :: (MonadError e m, Monoid w) => MonadError e (RWST r w s m) where
  throwError e = lift (throwError e)
  catchError m h = RWST $ \r s ->
    catchError
      (case m of RWST m' -> m' r s)
      (\e -> case h e of RWST m' -> m' r s)

instance monadRecRWST :: (MonadRec m, Monoid w) => MonadRec (RWST r w s m) where
  tailRecM k a = RWST \r s -> tailRecM (k' r) (RWSResult s a mempty)
    where
    k' r (RWSResult state result writer) =
      case k result of
        RWST m -> do
          RWSResult state' result' writer' <- m r state
          pure case result' of
            Loop x -> Loop (RWSResult state' x (writer <> writer'))
            Done y -> Done (RWSResult state' y (writer <> writer'))

instance plusRWST :: Plus m => Plus (RWST r w s m) where
  empty = RWST \ _ _ -> empty


comment failing tests

comment failing tests

module Test.Spec.ParallelSpec where

import Prelude

import Data.Time.Duration (Milliseconds(..))
import Effect.Aff (delay)
import Test.Spec (Spec, describe, it, parallel, pending, sequential)
-- import Test.Spec.Assertions (shouldEqual)

parallelSpec :: Spec Unit
parallelSpec = do
  describe "g" do
    it "g.1" $ delay $ Milliseconds 500.0
    it "g.2" $ delay $ Milliseconds 500.0
    pending "g.3"
  describe "p" do
    describe "pp" do
      describe "ppp" do
        pending "ppp.1"
  describe "a" $ parallel do
    -- it "a.err" $ delay (Milliseconds 300.0) *> 1 `shouldEqual` 2
    it "a.1" $ delay $ Milliseconds 1500.0
    it "a.2" $ delay $ Milliseconds 500.0
    describe "d" $ sequential do
      it "d.1" $ delay $ Milliseconds 500.0
      it "d.2" $ delay $ Milliseconds 500.0
    describe "z" do
      it "z.1" $ delay $ Milliseconds 700.0
      it "z.2" $ delay $ Milliseconds 900.0
      pending "z.3"
      -- it "z.err" $ delay (Milliseconds 300.0) *> 1 `shouldEqual` 2
    describe "j" do
      it "j.1" $ delay $ Milliseconds 1000.0
      it "j.2" $ delay $ Milliseconds 400.0
  describe "k" do
    it "k.1" $ delay $ Milliseconds 500.0
    it "k.2" $ delay $ Milliseconds 500.0

module Test.Spec.ParallelSpec where

import Prelude

import Data.Time.Duration (Milliseconds(..))
import Effect.Aff (delay)
import Test.Spec (Spec, describe, it, parallel, pending, sequential)
import Test.Spec.Assertions (shouldEqual)

parallelSpec :: Spec Unit
parallelSpec = do
  describe "g" do
    it "g.1" $ delay $ Milliseconds 500.0
    it "g.2" $ delay $ Milliseconds 500.0
    pending "g.3"
  describe "p" do
    describe "pp" do
      describe "ppp" do
        pending "ppp.1"
  describe "a" $ parallel do
    it "a.err" $ delay (Milliseconds 300.0) *> 1 `shouldEqual` 2
    it "a.1" $ delay $ Milliseconds 1500.0
    it "a.2" $ delay $ Milliseconds 500.0
    describe "d" $ sequential do
      it "d.1" $ delay $ Milliseconds 500.0
      it "d.2" $ delay $ Milliseconds 500.0
    describe "z" do
      it "z.1" $ delay $ Milliseconds 700.0
      it "z.2" $ delay $ Milliseconds 900.0
      pending "z.3"
      it "z.err" $ delay (Milliseconds 300.0) *> 1 `shouldEqual` 2
    describe "j" do
      it "j.1" $ delay $ Milliseconds 1000.0
      it "j.2" $ delay $ Milliseconds 400.0
  describe "k" do
    it "k.1" $ delay $ Milliseconds 500.0
    it "k.2" $ delay $ Milliseconds 500.0