As we switch to overview automatically - make baby screen default.

module Main where

import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Loaded as LoadedC
import Gonimo.UI.Loaded.Types as LoadedC
import Gonimo.UI.Socket as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Pux.Html.Attributes as A
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Servant.Subscriber.Subscriptions as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff, Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, REF, Ref)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (runIO, IO)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (modify, put, get)
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_)
import Data.Generic (gShow)
import Data.Lens (prism', PrismP, (^?))
import Data.List (toUnfoldable, reverse, List(Nil, Cons))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Profunctor (lmap)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Router (match, Route(AcceptInvitation, Home))
import Gonimo.Client.Types (toIO, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Client.Types (Settings)
import Gonimo.Pux (toPux, noEffects, wrapAction, onlyModify, Update, ComponentType, makeChildData, ToChild, liftChild, Component)
import Gonimo.Server.Types (DeviceType(NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Secret(Secret))
import Gonimo.UI.Error (viewError, handleError, class ErrorAction, UserError(NoError))
import Gonimo.UI.Html as Html
import Gonimo.Util (fromMaybeM, coerceEffects)
import Gonimo.WebAPI (postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (App, renderToDOM, fromSimple, start)
import Pux.Html (text, span, Html, img, div)
import Gonimo.Util (sampleUrl)
import Pux.Devtool (Action, start) as Pux.Devtool
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber, SubscriberEff)
import Servant.Subscriber.Connection (setPongRequest)
import Signal (foldp, map2, runSignal, constant, Signal)
import Signal.Channel (Channel, CHANNEL, send, subscribe, channel)
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (div)

data State = LoadingS LoadingS'
           | LoadedS LoadedC.State

_LoadingS :: PrismP State LoadingS'
_LoadingS = prism' LoadingS (\s -> case s of
                                LoadingS x -> Just x
                                _ -> Nothing)

_LoadedS :: PrismP State LoadedC.State
_LoadedS = prism' LoadedS (\s -> case s of
                                LoadedS x -> Just x
                                _ -> Nothing)

type LoadingS' = { actionQueue :: List LoadedC.Action -- | We queue actions until we are loaded.
                 , userError :: UserError
                 , sendAction :: Action -> Eff () Unit
                 }

type LoadedState = {
               authData :: AuthData
             , settings :: Settings
             }

init :: (Action -> Eff () Unit) -> State
init sendAction' = LoadingS { actionQueue : Nil
                            , userError : NoError
                            , sendAction : sendAction'
                            }

data Action = Start
            | Init LoadedC.State
            | ReportError GonimoError
            | LoadedA LoadedC.Action
            | ResetDevice
            | ClearError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

instance errorActionAction :: ErrorAction Action where
  resetDevice = ResetDevice
  nop = Nop
  clearError = ClearError

type MySubscriber = Subscriber () LoadedC.Action
--------------------------------------------------------------------------------

update :: Update Unit State Action
update action = do
  state <- ( get :: Component Unit State State)
  case action of
    Nop -> noEffects
    Init ls -> fromMaybe [] <$> handleInit ls
    _ -> fromMaybeM (fromMaybe [] <$> updateLoaded action) (updateLoading action)

toLoading :: ToChild Unit State Unit LoadingS'
toLoading = pure $ makeChildData _LoadingS unit

toLoaded :: ToChild Unit State Unit LoadedC.State
toLoaded = pure $ makeChildData _LoadedS unit

updateLoading' ::  Update Unit LoadingS' Action
updateLoading' action = do
  state <- get
  case action of
    Start           -> pure [ load state.sendAction ]
    LoadedA action  -> onlyModify $ \state' -> state' {
                          actionQueue = Cons action state.actionQueue
                        }
    Init ls         -> pure [ do
                                  Gonimo.log "Init command should be handled in toplevel update!"
                                  pure Nop
                              ]
    ReportError err -> handleError err
    ResetDevice     -> handleResetDevice
    ClearError      -> do
      modify $ _ { userError = NoError }
      pure $ wrapAction Start
    Nop             -> noEffects

handleResetDevice :: ComponentType Unit LoadingS' Action
handleResetDevice = pure $ [ do
  liftEff $ localStorage.removeItem Key.authData
  pure Start
 ]
updateLoading :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoading = liftChild toLoading <<< updateLoading'

updateLoaded :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded action = case action of
  LoadedA act -> updateLoaded' act
  (ReportError err) -> updateLoaded' (LoadedC.ReportError err)
  _ -> do
       state <- get
       case state of
        LoadedS _ -> pure <<< Just $
                     [ do Gonimo.log "Only LoadedA actions are supported when loaded"
                          pure Nop
                     ]
        _ -> pure Nothing

updateLoaded' :: LoadedC.Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded' = map (map (map (map LoadedA))) <<< liftChild toLoaded <<< LoadedC.update

handleInit :: LoadedC.State -> Component Unit State (Maybe (Array (IO Action)))
handleInit ls = do
    state <- get
    case state ^? _LoadingS of
      Nothing -> pure Nothing
      Just loadingS -> do
        let queueEffects = map (pure <<< LoadedA)
                           <<< reverse
                           <<< Cons LoadedC.Init
                           $ loadingS.actionQueue
        put $ LoadedS ls
        pure <<< Just $ toUnfoldable queueEffects

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

view :: State -> Html Action
view (LoadingS state) = viewLoading state
view (LoadedS state)  = map LoadedA $ LoadedC.view state

viewLoading :: LoadingS' -> Html Action
viewLoading state = case state.userError of
      NoError -> Html.viewLoading "Loading your gonimo, stay tight ..."
      _ -> viewError state

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

load :: (Action -> Eff () Unit) -> IO Action
load sendAction' = Gonimo.toIO initSettings $ authToAction =<< LoadedC.getAuthData
  where
    initSettings = mkSettings $ GonimoSecret (Secret "blabala")

    mkSettings :: AuthToken -> Settings
    mkSettings secret = defaultSettings $ SPParams_ {
          authorization : secret
        , baseURL       : "http://localhost:8081/"
        }

    authToAction :: AuthData -> Gonimo Action
    authToAction (authData@(AuthData auth)) = do
      pure $ Init
            { subscriberUrl : "ws://localhost:8081/subscriber"
            , overviewS         : OverviewC.init
            , socketS       : SocketC.init authData
            , central       : LoadedC.CentralBaby
            , familyIds     : []
            , families      : Map.empty
            , url           : ""
            , onlineDevices : []
            , deviceInfos   : []
            , userError     : NoError
            , sendAction    : lmap LoadedA sendAction'
            , babiesOnlineCount : 0
            }

makeCallback :: forall eff. Channel Action ->  (LoadedC.Action -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeCallback c = send c <<< LoadedA

makeNotify :: forall eff. Channel Action ->  (Sub.Notification -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeNotify c = send c <<< LoadedA <<< LoadedC.HandleSubscriber

deploySubscriptions :: IO (Maybe MySubscriber) -> State -> IO Unit
deploySubscriptions _ (LoadingS _) = pure unit
deploySubscriptions getSubscriber (LoadedS s) = do
  let subscriptions = LoadedC.getSubscriptions s
  subscriber <- getSubscriber
  case subscriber of
    Nothing -> Console.log "Not deploying - no subscriber yet!"
    Just subscriber' -> do
      liftEff $ traverse_ (flip Sub.setPongRequest  (Sub.getConnection subscriber')) $ LoadedC.getPongRequest s
      liftEff $ traverse_ (flip Sub.setCloseRequest (Sub.getConnection subscriber')) $ LoadedC.getCloseRequest s
      liftEff $ Sub.deploy subscriptions subscriber'

-- | Don't use a foldp instead of Ref - you will build up an endless thunk of actions in memory.
renewSubscriber :: Channel Action -> Ref (Maybe MySubscriber)
                   -> State -> IO (Maybe MySubscriber)
renewSubscriber controlChan subscriberRef state = do
    oldSub <- liftEff $ readRef subscriberRef
    let oldUrl = Sub.getUrl <<< Sub.getConnection <$> oldSub
    let newUrl = case state of
          LoadedS lState -> Just lState.subscriberUrl
          _ -> Nothing
    if (newUrl /= oldUrl)
      then do
        Console.log $ "Closing old subscriber ..."
        liftEff $ traverse_ (Sub.close <<< Sub.getConnection) oldSub
        newSub <- traverse makeMySubscriber newUrl
        liftEff $ writeRef subscriberRef newSub
        pure newSub
       else
        pure oldSub
  where
    makeMySubscriber :: String -> IO MySubscriber
    makeMySubscriber url' = do
        map coerceSubscriberEffects <<< liftEff $ Sub.makeSubscriber
                  { url : url'
                  , callback : makeCallback controlChan
                  , notify : makeNotify controlChan
                  }

main = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  -- runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

debug = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- Pux.Devtool.start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  -- runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

coerceSubscriberEffects :: forall eff1 eff2 a. Subscriber eff1 a -> Subscriber eff2 a
coerceSubscriberEffects = unsafeCoerce

module Main where

import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Loaded as LoadedC
import Gonimo.UI.Loaded.Types as LoadedC
import Gonimo.UI.Socket as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Pux.Html.Attributes as A
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Servant.Subscriber.Subscriptions as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff, Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, REF, Ref)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (runIO, IO)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (modify, put, get)
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_)
import Data.Generic (gShow)
import Data.Lens (prism', PrismP, (^?))
import Data.List (toUnfoldable, reverse, List(Nil, Cons))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Profunctor (lmap)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Router (match, Route(AcceptInvitation, Home))
import Gonimo.Client.Types (toIO, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Client.Types (Settings)
import Gonimo.Pux (toPux, noEffects, wrapAction, onlyModify, Update, ComponentType, makeChildData, ToChild, liftChild, Component)
import Gonimo.Server.Types (DeviceType(NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Secret(Secret))
import Gonimo.UI.Error (viewError, handleError, class ErrorAction, UserError(NoError))
import Gonimo.UI.Html as Html
import Gonimo.Util (fromMaybeM, coerceEffects)
import Gonimo.WebAPI (postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (App, renderToDOM, fromSimple, start)
import Pux.Html (text, span, Html, img, div)
import Gonimo.Util (sampleUrl)
import Pux.Devtool (Action, start) as Pux.Devtool
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber, SubscriberEff)
import Servant.Subscriber.Connection (setPongRequest)
import Signal (foldp, map2, runSignal, constant, Signal)
import Signal.Channel (Channel, CHANNEL, send, subscribe, channel)
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (div)

data State = LoadingS LoadingS'
           | LoadedS LoadedC.State

_LoadingS :: PrismP State LoadingS'
_LoadingS = prism' LoadingS (\s -> case s of
                                LoadingS x -> Just x
                                _ -> Nothing)

_LoadedS :: PrismP State LoadedC.State
_LoadedS = prism' LoadedS (\s -> case s of
                                LoadedS x -> Just x
                                _ -> Nothing)

type LoadingS' = { actionQueue :: List LoadedC.Action -- | We queue actions until we are loaded.
                 , userError :: UserError
                 , sendAction :: Action -> Eff () Unit
                 }

type LoadedState = {
               authData :: AuthData
             , settings :: Settings
             }

init :: (Action -> Eff () Unit) -> State
init sendAction' = LoadingS { actionQueue : Nil
                            , userError : NoError
                            , sendAction : sendAction'
                            }

data Action = Start
            | Init LoadedC.State
            | ReportError GonimoError
            | LoadedA LoadedC.Action
            | ResetDevice
            | ClearError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

instance errorActionAction :: ErrorAction Action where
  resetDevice = ResetDevice
  nop = Nop
  clearError = ClearError

type MySubscriber = Subscriber () LoadedC.Action
--------------------------------------------------------------------------------

update :: Update Unit State Action
update action = do
  state <- ( get :: Component Unit State State)
  case action of
    Nop -> noEffects
    Init ls -> fromMaybe [] <$> handleInit ls
    _ -> fromMaybeM (fromMaybe [] <$> updateLoaded action) (updateLoading action)

toLoading :: ToChild Unit State Unit LoadingS'
toLoading = pure $ makeChildData _LoadingS unit

toLoaded :: ToChild Unit State Unit LoadedC.State
toLoaded = pure $ makeChildData _LoadedS unit

updateLoading' ::  Update Unit LoadingS' Action
updateLoading' action = do
  state <- get
  case action of
    Start           -> pure [ load state.sendAction ]
    LoadedA action  -> onlyModify $ \state' -> state' {
                          actionQueue = Cons action state.actionQueue
                        }
    Init ls         -> pure [ do
                                  Gonimo.log "Init command should be handled in toplevel update!"
                                  pure Nop
                              ]
    ReportError err -> handleError err
    ResetDevice     -> handleResetDevice
    ClearError      -> do
      modify $ _ { userError = NoError }
      pure $ wrapAction Start
    Nop             -> noEffects

handleResetDevice :: ComponentType Unit LoadingS' Action
handleResetDevice = pure $ [ do
  liftEff $ localStorage.removeItem Key.authData
  pure Start
 ]
updateLoading :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoading = liftChild toLoading <<< updateLoading'

updateLoaded :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded action = case action of
  LoadedA act -> updateLoaded' act
  (ReportError err) -> updateLoaded' (LoadedC.ReportError err)
  _ -> do
       state <- get
       case state of
        LoadedS _ -> pure <<< Just $
                     [ do Gonimo.log "Only LoadedA actions are supported when loaded"
                          pure Nop
                     ]
        _ -> pure Nothing

updateLoaded' :: LoadedC.Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded' = map (map (map (map LoadedA))) <<< liftChild toLoaded <<< LoadedC.update

handleInit :: LoadedC.State -> Component Unit State (Maybe (Array (IO Action)))
handleInit ls = do
    state <- get
    case state ^? _LoadingS of
      Nothing -> pure Nothing
      Just loadingS -> do
        let queueEffects = map (pure <<< LoadedA)
                           <<< reverse
                           <<< Cons LoadedC.Init
                           $ loadingS.actionQueue
        put $ LoadedS ls
        pure <<< Just $ toUnfoldable queueEffects

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

view :: State -> Html Action
view (LoadingS state) = viewLoading state
view (LoadedS state)  = map LoadedA $ LoadedC.view state

viewLoading :: LoadingS' -> Html Action
viewLoading state = case state.userError of
      NoError -> Html.viewLoading "Loading your gonimo, stay tight ..."
      _ -> viewError state

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

load :: (Action -> Eff () Unit) -> IO Action
load sendAction' = Gonimo.toIO initSettings $ authToAction =<< LoadedC.getAuthData
  where
    initSettings = mkSettings $ GonimoSecret (Secret "blabala")

    mkSettings :: AuthToken -> Settings
    mkSettings secret = defaultSettings $ SPParams_ {
          authorization : secret
        , baseURL       : "http://localhost:8081/"
        }

    authToAction :: AuthData -> Gonimo Action
    authToAction (authData@(AuthData auth)) = do
      pure $ Init
            { subscriberUrl : "ws://localhost:8081/subscriber"
            , overviewS         : OverviewC.init
            , socketS       : SocketC.init authData
            , central       : LoadedC.CentralOverview
            , familyIds     : []
            , families      : Map.empty
            , url           : ""
            , onlineDevices : []
            , deviceInfos   : []
            , userError     : NoError
            , sendAction    : lmap LoadedA sendAction'
            , babiesOnlineCount : 0
            }

makeCallback :: forall eff. Channel Action ->  (LoadedC.Action -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeCallback c = send c <<< LoadedA

makeNotify :: forall eff. Channel Action ->  (Sub.Notification -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeNotify c = send c <<< LoadedA <<< LoadedC.HandleSubscriber

deploySubscriptions :: IO (Maybe MySubscriber) -> State -> IO Unit
deploySubscriptions _ (LoadingS _) = pure unit
deploySubscriptions getSubscriber (LoadedS s) = do
  let subscriptions = LoadedC.getSubscriptions s
  subscriber <- getSubscriber
  case subscriber of
    Nothing -> Console.log "Not deploying - no subscriber yet!"
    Just subscriber' -> do
      liftEff $ traverse_ (flip Sub.setPongRequest  (Sub.getConnection subscriber')) $ LoadedC.getPongRequest s
      liftEff $ traverse_ (flip Sub.setCloseRequest (Sub.getConnection subscriber')) $ LoadedC.getCloseRequest s
      liftEff $ Sub.deploy subscriptions subscriber'

-- | Don't use a foldp instead of Ref - you will build up an endless thunk of actions in memory.
renewSubscriber :: Channel Action -> Ref (Maybe MySubscriber)
                   -> State -> IO (Maybe MySubscriber)
renewSubscriber controlChan subscriberRef state = do
    oldSub <- liftEff $ readRef subscriberRef
    let oldUrl = Sub.getUrl <<< Sub.getConnection <$> oldSub
    let newUrl = case state of
          LoadedS lState -> Just lState.subscriberUrl
          _ -> Nothing
    if (newUrl /= oldUrl)
      then do
        Console.log $ "Closing old subscriber ..."
        liftEff $ traverse_ (Sub.close <<< Sub.getConnection) oldSub
        newSub <- traverse makeMySubscriber newUrl
        liftEff $ writeRef subscriberRef newSub
        pure newSub
       else
        pure oldSub
  where
    makeMySubscriber :: String -> IO MySubscriber
    makeMySubscriber url' = do
        map coerceSubscriberEffects <<< liftEff $ Sub.makeSubscriber
                  { url : url'
                  , callback : makeCallback controlChan
                  , notify : makeNotify controlChan
                  }

main = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  -- runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

debug = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- Pux.Devtool.start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  -- runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

coerceSubscriberEffects :: forall eff1 eff2 a. Subscriber eff1 a -> Subscriber eff2 a
coerceSubscriberEffects = unsafeCoerce


rev imports (originally just copied from D1,P1)

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/michaelsbradleyjr/advent-of-code.git/'


add more tests

add more tests

module Tests.Data.Map where

import Debug.Trace

import Control.Alt ((<|>))
import Data.Maybe
import Data.Tuple
import Data.Array (map, length, nubBy)
import Data.Function (on)
import Data.Foldable (foldl, for_)

import Test.QuickCheck

import qualified Data.Map as M

instance arbMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (M.Map k v) where
  arbitrary = M.fromList <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance eqSmallKey :: Eq SmallKey where
  (==) A A = true
  (==) B B = true
  (==) C C = true
  (==) D D = true
  (==) E E = true
  (==) F F = true
  (==) G G = true
  (==) H H = true
  (==) I I = true
  (==) J J = true
  (==) _ _ = false
  (/=) x y = not (x == y)

smallKeyToNumber :: SmallKey -> Number
smallKeyToNumber A = 0
smallKeyToNumber B = 1
smallKeyToNumber C = 2
smallKeyToNumber D = 3
smallKeyToNumber E = 4
smallKeyToNumber F = 5
smallKeyToNumber G = 6
smallKeyToNumber H = 7
smallKeyToNumber I = 8
smallKeyToNumber J = 9

instance ordSmallKey :: Ord SmallKey where
  compare = compare `on` smallKeyToNumber

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = do
    n <- arbitrary
    return case n of
      _ | n < 0.1 -> A
      _ | n < 0.2 -> B
      _ | n < 0.3 -> C
      _ | n < 0.4 -> D
      _ | n < 0.5 -> E
      _ | n < 0.6 -> F
      _ | n < 0.7 -> G
      _ | n < 0.8 -> H
      _ | n < 0.9 -> I
      _ -> J

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" ++ show k ++ ") (" ++ show v ++ ")"
  show (Delete k) = "Delete (" ++ show k ++ ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = do
    b <- arbitrary
    case b of
      true -> do
        k <- arbitrary
        v <- arbitrary
        return (Insert k v)
      false -> do
        k <- arbitrary
        return (Delete k)

runInstructions :: forall k v. (Ord k) => [Instruction k v] -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Number -> Number
number n = n

mapTests = do

  -- Data.Map

  trace "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  trace "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  trace "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  trace "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  trace "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  trace "Check balance property"
  quickCheck' 5000 $ \instrs ->
    let
      tree :: M.Map SmallKey Number
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " ++ show tree ++ "\nGenerated by:\n  " ++ show instrs)

  trace "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Number) == Nothing

  trace "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Number)) == Just v

  trace "Random lookup"
  quickCheck' 5000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Number
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " ++ show instrs ++ "\nk:\n  " ++ show k ++ "\nv:\n  " ++ show v)

  trace "Singleton to list"
  quickCheck $ \k v -> M.toList (M.singleton k v :: M.Map SmallKey Number) == [Tuple k v]

  trace "toList . fromList = id"
  quickCheck $ \arr -> let f x = M.toList (M.fromList x)
                       in f (f arr) == f (arr :: [Tuple SmallKey Number]) <?> show arr

  trace "fromList . toList = id"
  quickCheck $ \m -> let f m = M.fromList (M.toList m) in
                     M.toList (f m) == M.toList (m :: M.Map SmallKey Number) <?> show m

  trace "Lookup from union"
  quickCheck $ \m1 m2 k -> M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
    Nothing -> M.lookup k m2
    Just v -> Just (number v)) <?> ("m1: " ++ show m1 ++ ", m2: " ++ show m2 ++ ", k: " ++ show k ++ ", v1: " ++ show (M.lookup k m1) ++ ", v2: " ++ show (M.lookup k m2) ++ ", union: " ++ show (M.union m1 m2))

  trace "Union is idempotent"
  quickCheck $ \m1 m2 -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Number))

  trace "Union prefers left"
  quickCheck $ \m1 m2 k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Number)) == (M.lookup k m1 <|> M.lookup k m2)

  trace "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \m1 m2 k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Number
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  trace "unionWith argument order"
  quickCheck $ \m1 m2 k ->
    let u   = M.unionWith (-) m1 m2 :: M.Map SmallKey Number
        in1 = M.member k m1
        v1  = M.lookup k m1
        in2 = M.member k m2
        v2  = M.lookup k m2
    in case M.lookup k u of
          Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2)
          Just v | in1        -> Just v == v1
          Just v              -> Just v == v2
          Nothing             -> not (in1 || in2)

  trace "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromList xs') == length (xs' :: [Tuple SmallKey Number])

module Tests.Data.Map where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Array (map, length, nubBy)
import Data.Function (on)
import Data.Foldable (foldl, for_)

import Test.QuickCheck

import qualified Data.Map as M

instance arbMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (M.Map k v) where
  arbitrary = M.fromList <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance eqSmallKey :: Eq SmallKey where
  (==) A A = true
  (==) B B = true
  (==) C C = true
  (==) D D = true
  (==) E E = true
  (==) F F = true
  (==) G G = true
  (==) H H = true
  (==) I I = true
  (==) J J = true
  (==) _ _ = false
  (/=) x y = not (x == y)

smallKeyToNumber :: SmallKey -> Number
smallKeyToNumber A = 0
smallKeyToNumber B = 1
smallKeyToNumber C = 2
smallKeyToNumber D = 3
smallKeyToNumber E = 4
smallKeyToNumber F = 5
smallKeyToNumber G = 6
smallKeyToNumber H = 7
smallKeyToNumber I = 8
smallKeyToNumber J = 9

instance ordSmallKey :: Ord SmallKey where
  compare = compare `on` smallKeyToNumber

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = do
    n <- arbitrary
    return case n of
      _ | n < 0.1 -> A
      _ | n < 0.2 -> B
      _ | n < 0.3 -> C
      _ | n < 0.4 -> D
      _ | n < 0.5 -> E
      _ | n < 0.6 -> F
      _ | n < 0.7 -> G
      _ | n < 0.8 -> H
      _ | n < 0.9 -> I
      _ -> J

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" ++ show k ++ ") (" ++ show v ++ ")"
  show (Delete k) = "Delete (" ++ show k ++ ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = do
    b <- arbitrary
    case b of
      true -> do
        k <- arbitrary
        v <- arbitrary
        return (Insert k v)
      false -> do
        k <- arbitrary
        return (Delete k)

runInstructions :: forall k v. (Ord k) => [Instruction k v] -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Number -> Number
number n = n

mapTests = do

  -- Data.Map

  trace "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  trace "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  trace "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  trace "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  trace "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  trace "Check balance property"
  quickCheck' 5000 $ \instrs ->
    let
      tree :: M.Map SmallKey Number
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " ++ show tree ++ "\nGenerated by:\n  " ++ show instrs)

  trace "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Number) == Nothing

  trace "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Number)) == Just v

  trace "Random lookup"
  quickCheck' 5000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Number
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " ++ show instrs ++ "\nk:\n  " ++ show k ++ "\nv:\n  " ++ show v)

  trace "Singleton to list"
  quickCheck $ \k v -> M.toList (M.singleton k v :: M.Map SmallKey Number) == [Tuple k v]

  trace "toList . fromList = id"
  quickCheck $ \arr -> let f x = M.toList (M.fromList x)
                       in f (f arr) == f (arr :: [Tuple SmallKey Number]) <?> show arr

  trace "fromList . toList = id"
  quickCheck $ \m -> let f m = M.fromList (M.toList m) in
                     M.toList (f m) == M.toList (m :: M.Map SmallKey Number) <?> show m

  trace "Lookup from union"
  quickCheck $ \m1 m2 k -> M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
    Nothing -> M.lookup k m2
    Just v -> Just (number v)) <?> ("m1: " ++ show m1 ++ ", m2: " ++ show m2 ++ ", k: " ++ show k ++ ", v1: " ++ show (M.lookup k m1) ++ ", v2: " ++ show (M.lookup k m2) ++ ", union: " ++ show (M.union m1 m2))

  trace "Union is idempotent"
  quickCheck $ \m1 m2 -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Number))

  trace "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \m1 m2 k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Number
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  trace "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromList xs') == length (xs' :: [Tuple SmallKey Number])


Keep ints in the range of int32

Keep ints in the range of int32

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0;
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance ringInt :: Ring Int where
  (-) = intSub

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return (x + y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return (x * y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intMod(x) {
    return function(y) {
      return x % y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intSub
  """
  function intSub(x) {
    return function(y) {
      return (x - y)|0;
    };
  }
  """ :: Int -> Int -> Int

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0;
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance ringInt :: Ring Int where
  (-) = intSub

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return x + y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return x * y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intMod(x) {
    return function(y) {
      return x % y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intSub
  """
  function intSub(x) {
    return function(y) {
      return x - y;
    };
  }
  """ :: Int -> Int -> Int


Add plural-versions of remaining units, fixes #71

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , functions
  , siPrefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, atto, bit, byte, centi, cup, day, deci, degree,
                   exa, femto, foot, giga, gram, gallon, hecto, hertz, hour,
                   inch, joule, kilo, mega, meter, micro, mile, milli, minute,
                   nano, newton, ounce, peta, pico, pint, pound, radian, second,
                   tera, watt, week, yard, (./), pascal, coulomb, volt, farad,
                   ohm, siemens, weber, tesla, henry, lumen, lux, becquerel,
                   gray, sievert, katal, hectare, liter, tablespoon, teaspoon,
                   tonne, electronvolt, ampere, mole, kelvin, candela, month,
                   year)

import Data.Array (some, fromFoldable)
import Data.Either (Either(..))
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Foldable (foldr, foldMap)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.String (fromCharArray, singleton)
import Data.Tuple (Tuple(..))

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '^', '!', '→', '=']
  , opLetter: oneOf ['>', '*']
  , reservedNames: commands <> ["²", "³", "to"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "^", "!",
                      "**", "="]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton sign <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

siPrefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
siPrefixDict = Dictionary
  [ atto ==> ["a"]
  , femto ==> ["f"]
  , pico ==> ["p"]
  , nano ==> ["n"]
  , micro ==> [ "µ" -- Micro sign U+00B5
              , "μ" -- Greek small letter mu U+039C
              ]
  , milli ==> ["m"]
  , centi ==> ["c"]
  , deci ==> ["d"]
  , hecto ==> ["h"]
  , kilo ==> ["k"]
  , mega ==> ["M"]
  , giga ==> ["G"]
  , tera ==> ["T"]
  , peta ==> ["P"]
  , exa ==> ["E"]
  ]

-- | Parse a SI prefix like `µ` or `G`.
siPrefix ∷ P (DerivedUnit → DerivedUnit)
siPrefix = buildDictParser siPrefixDict <|> pure id

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ radian ==> ["radians", "radian", "rad"]
  , degree ==> ["degrees", "degree", "deg", "°"]
  , hertz ==> ["hertz", "Hz"]
  , newton ==> ["newton", "N"]
  , joule ==> ["joules", "joule", "J"]
  , pascal ==> ["pascal", "Pa"]
  , volt ==> ["volts", "volt", "V"]
  , farad ==> ["farad", "F"]
  , ohm ==> ["ohms", "ohm", "Ω"]
  , sievert ==> ["sievert", "Sv"]
  , weber ==> ["weber", "Wb"]
  , tesla ==> ["tesla", "T"]
  , henry ==> ["henry", "H"]
  , coulomb ==> ["coulomb", "C"]
  , siemens ==> ["siemens", "S"]
  , lumen ==> ["lumen", "lm"]
  , lux ==> ["lux", "lx"]
  , becquerel ==> ["becquerel", "Bq"]
  , gray ==> ["gray", "Gy"]
  , katal ==> ["katal", "kat"]
  , hectare ==> ["hectare", "ha"]
  , liter ==> ["liters", "liter", "L"]
  , tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , electronvolt ==> ["electronvolt", "eV"]
  , ampere ==> ["amperes", "ampere", "A"]
  , mole ==> ["mole", "mol"]
  , kelvin ==> ["kelvin", "K"]
  , candela ==> ["candela", "cd"]
  , watt ==> ["watts", "watt", "W"]
  , byte ==> ["Bytes", "bytes", "Byte", "byte", "B"]
  , bit ==> ["bits", "bit"]
  , bit ./ second ==> ["bps"]
  , second ==> ["seconds", "second", "sec", "s"]
  , minute ==> ["minutes", "minute", "min"]
  , hour ==> ["hours", "hour", "h"]
  , day ==> ["days", "day"]
  , week ==> ["weeks", "week"]
  , month ==> ["months", "month"]
  , year ==> ["years", "year"]
  , gram ==> ["grams", "gram", "g"]
  , meter ==> ["meters", "meter", "m"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ mile ==> ["miles", "mile"]
  , mile ./ hour ==> ["mph"]
  , inch ==> ["inches", "inch", "in"]
  , yard ==> ["yards", "yard", "yd"]
  , foot ==> ["feet", "foot", "ft"]
  , ounce ==> ["ounces", "ounce", "oz"]
  , pound ==> ["pounds", "pound", "lb"]
  , gallon ==> ["gallons", "gallon", "gal"]
  , pint ==> ["pints", "pint"]
  , cup ==> ["cups", "cup"]
  , tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← siPrefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | Possible names for the mathematical functions.
funcNameDict ∷ Dictionary Func
funcNameDict = Dictionary
  [ Acosh ==> ["acosh"]
  , Acos ==> ["acos"]
  , Asinh ==> ["asinh"]
  , Asin ==> ["asin"]
  , Atanh ==> ["atanh"]
  , Atan ==> ["atan"]
  , Ceil ==> ["ceil"]
  , Cosh ==> ["cosh"]
  , Cos ==> ["cos"]
  , Exp ==> ["exp"]
  , Floor ==> ["floor"]
  , Gamma ==> ["gamma"]
  , Log10 ==> ["log10"]
  , Ln ==> ["log", "ln"]
  , Round ==> ["round"]
  , Sinh ==> ["sinh"]
  , Sin ==> ["sin"]
  , Sqrt ==> ["sqrt"]
  , Tanh ==> ["tanh"]
  , Tan ==> ["tan"]
  ]

-- | A list of all mathematical function names (for tab-completion).
functions ∷ Array String
functions =
  case funcNameDict of
    Dictionary dict → foldMap (\(_ ==> names) → names) dict

-- | Parse the name of a mathematical function.
funcName ∷ P Func
funcName = buildDictParser funcNameDict <?> "function name"

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a full mathematical expression.
expression ∷ P Expression
expression =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> funcName <*> (parens p <* whiteSpace))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe ((sqrOp *> pure square) <|> (cubOp *> pure cube))
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByMulImplicit `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    -- these two need to be parsed as keywords in order to allow for other
    -- operators to follow (e.g. 3²*2)
    sqrOp = reserved "²"
    cubOp = reserved "³"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reserved "to"

    square q = BinOp Pow q (Scalar $ fromNumber 2.0)
    cube q = BinOp Pow q (Scalar $ fromNumber 3.0)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ P Expression
fullExpression = do
  whiteSpace
  expr ← expression
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable assignment like `x = 3m*pi`
assignment ∷ P (Tuple String Expression)
assignment = do
  whiteSpace
  var ← token.identifier
  reservedOp "="
  value ← expression
  eof
  pure $ Tuple var value

-- | Try to parse the identifier as a unit, and fail if it succeeds.
checkIdentifier ∷ Tuple String Expression → P Statement
checkIdentifier (Tuple var value) =
  case runParser var (derivedUnit <* eof) of
    Right _ →
      fail $ "'" <> var <> "' is reserved for a physical unit"
    Left _ →
      case runParser var (funcName <* eof) of
        Right _ →
          fail $ "'" <> var <> "' is reserved for a math. function"
        Left _ →
          pure $ Assignment var value

-- | Parse a statement in the Insect language.
statement ∷ P Statement
statement =
      (Command <$> command)
  <|> (try assignment >>= checkIdentifier)
  <|> (Expression <$> fullExpression)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ String → Either ParseError Statement
parseInsect inp = runParser inp statement

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , functions
  , siPrefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, atto, bit, byte, centi, cup, day, deci, degree,
                   exa, femto, foot, giga, gram, gallon, hecto, hertz, hour,
                   inch, joule, kilo, mega, meter, micro, mile, milli, minute,
                   nano, newton, ounce, peta, pico, pint, pound, radian, second,
                   tera, watt, week, yard, (./), pascal, coulomb, volt, farad,
                   ohm, siemens, weber, tesla, henry, lumen, lux, becquerel,
                   gray, sievert, katal, hectare, liter, tablespoon, teaspoon,
                   tonne, electronvolt, ampere, mole, kelvin, candela, month,
                   year)

import Data.Array (some, fromFoldable)
import Data.Either (Either(..))
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Foldable (foldr, foldMap)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.String (fromCharArray, singleton)
import Data.Tuple (Tuple(..))

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '^', '!', '→', '=']
  , opLetter: oneOf ['>', '*']
  , reservedNames: commands <> ["²", "³", "to"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "^", "!",
                      "**", "="]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton sign <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

siPrefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
siPrefixDict = Dictionary
  [ atto ==> ["a"]
  , femto ==> ["f"]
  , pico ==> ["p"]
  , nano ==> ["n"]
  , micro ==> [ "µ" -- Micro sign U+00B5
              , "μ" -- Greek small letter mu U+039C
              ]
  , milli ==> ["m"]
  , centi ==> ["c"]
  , deci ==> ["d"]
  , hecto ==> ["h"]
  , kilo ==> ["k"]
  , mega ==> ["M"]
  , giga ==> ["G"]
  , tera ==> ["T"]
  , peta ==> ["P"]
  , exa ==> ["E"]
  ]

-- | Parse a SI prefix like `µ` or `G`.
siPrefix ∷ P (DerivedUnit → DerivedUnit)
siPrefix = buildDictParser siPrefixDict <|> pure id

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ radian ==> ["radians", "radian", "rad"]
  , degree ==> ["degrees", "degree", "deg", "°"]
  , hertz ==> ["hertz", "Hz"]
  , newton ==> ["newton", "N"]
  , joule ==> ["joules", "joule", "J"]
  , pascal ==> ["pascal", "Pa"]
  , volt ==> ["volt", "V"]
  , farad ==> ["farad", "F"]
  , ohm ==> ["ohm", "Ω"]
  , sievert ==> ["sievert", "Sv"]
  , weber ==> ["weber", "Wb"]
  , tesla ==> ["tesla", "T"]
  , henry ==> ["henry", "H"]
  , coulomb ==> ["coulomb", "C"]
  , siemens ==> ["siemens", "S"]
  , lumen ==> ["lumen", "lm"]
  , lux ==> ["lux", "lx"]
  , becquerel ==> ["becquerel", "Bq"]
  , gray ==> ["gray", "Gy"]
  , katal ==> ["katal", "kat"]
  , hectare ==> ["hectare", "ha"]
  , liter ==> ["liters", "liter", "L"]
  , tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , electronvolt ==> ["electronvolt", "eV"]
  , ampere ==> ["ampere", "A"]
  , mole ==> ["mole", "mol"]
  , kelvin ==> ["kelvin", "K"]
  , candela ==> ["candela", "cd"]
  , watt ==> ["watts", "watt", "W"]
  , byte ==> ["Bytes", "bytes", "Byte", "byte", "B"]
  , bit ==> ["bits", "bit"]
  , bit ./ second ==> ["bps"]
  , second ==> ["seconds", "second", "sec", "s"]
  , minute ==> ["minutes", "minute", "min"]
  , hour ==> ["hours", "hour", "h"]
  , day ==> ["days", "day"]
  , week ==> ["weeks", "week"]
  , month ==> ["months", "month"]
  , year ==> ["years", "year"]
  , gram ==> ["grams", "gram", "g"]
  , meter ==> ["meters", "meter", "m"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ mile ==> ["miles", "mile"]
  , mile ./ hour ==> ["mph"]
  , inch ==> ["inches", "inch", "in"]
  , yard ==> ["yards", "yard", "yd"]
  , foot ==> ["feet", "foot", "ft"]
  , ounce ==> ["ounces", "ounce", "oz"]
  , pound ==> ["pounds", "pound", "lb"]
  , gallon ==> ["gallons", "gallon", "gal"]
  , pint ==> ["pints", "pint"]
  , cup ==> ["cups", "cup"]
  , tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← siPrefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | Possible names for the mathematical functions.
funcNameDict ∷ Dictionary Func
funcNameDict = Dictionary
  [ Acosh ==> ["acosh"]
  , Acos ==> ["acos"]
  , Asinh ==> ["asinh"]
  , Asin ==> ["asin"]
  , Atanh ==> ["atanh"]
  , Atan ==> ["atan"]
  , Ceil ==> ["ceil"]
  , Cosh ==> ["cosh"]
  , Cos ==> ["cos"]
  , Exp ==> ["exp"]
  , Floor ==> ["floor"]
  , Gamma ==> ["gamma"]
  , Log10 ==> ["log10"]
  , Ln ==> ["log", "ln"]
  , Round ==> ["round"]
  , Sinh ==> ["sinh"]
  , Sin ==> ["sin"]
  , Sqrt ==> ["sqrt"]
  , Tanh ==> ["tanh"]
  , Tan ==> ["tan"]
  ]

-- | A list of all mathematical function names (for tab-completion).
functions ∷ Array String
functions =
  case funcNameDict of
    Dictionary dict → foldMap (\(_ ==> names) → names) dict

-- | Parse the name of a mathematical function.
funcName ∷ P Func
funcName = buildDictParser funcNameDict <?> "function name"

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a full mathematical expression.
expression ∷ P Expression
expression =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> funcName <*> (parens p <* whiteSpace))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe ((sqrOp *> pure square) <|> (cubOp *> pure cube))
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByMulImplicit `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    -- these two need to be parsed as keywords in order to allow for other
    -- operators to follow (e.g. 3²*2)
    sqrOp = reserved "²"
    cubOp = reserved "³"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reserved "to"

    square q = BinOp Pow q (Scalar $ fromNumber 2.0)
    cube q = BinOp Pow q (Scalar $ fromNumber 3.0)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ P Expression
fullExpression = do
  whiteSpace
  expr ← expression
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable assignment like `x = 3m*pi`
assignment ∷ P (Tuple String Expression)
assignment = do
  whiteSpace
  var ← token.identifier
  reservedOp "="
  value ← expression
  eof
  pure $ Tuple var value

-- | Try to parse the identifier as a unit, and fail if it succeeds.
checkIdentifier ∷ Tuple String Expression → P Statement
checkIdentifier (Tuple var value) =
  case runParser var (derivedUnit <* eof) of
    Right _ →
      fail $ "'" <> var <> "' is reserved for a physical unit"
    Left _ →
      case runParser var (funcName <* eof) of
        Right _ →
          fail $ "'" <> var <> "' is reserved for a math. function"
        Left _ →
          pure $ Assignment var value

-- | Parse a statement in the Insect language.
statement ∷ P Statement
statement =
      (Command <$> command)
  <|> (try assignment >>= checkIdentifier)
  <|> (Expression <$> fullExpression)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ String → Either ParseError Statement
parseInsect inp = runParser inp statement


adds an example source file

adds an example source file

module Main where

import Control.Monad.Eff

import Prelude
import Data.Argonaut ((~>), (:=), (.?), jsonEmptyObject, printJson, jsonParser)
import Data.Argonaut.Core
import Data.Argonaut.Encode (EncodeJson, encodeJson)
import Data.Argonaut.Decode (DecodeJson, decodeJson)

import Data.Array (tail)
import Data.Either
import Data.Maybe
import Data.Maybe.Unsafe
import Data.String (split)

data PSType = Package | Ident

instance showPSType :: Show PSType where
  show Package = "package"
  show Ident   = "completion"

instance encodePSType :: EncodeJson PSType where
  encodeJson = encodeJson <<< show

data Matcher = Flex String

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

data Command =
  Cwd
  | Ls
  | Quit
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher)
  | Pursuit PSType String

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson Ls = jsonSingletonObject' "command" "list"
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeJson matcher)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype Completion = Completion (GenCompletion ())
newtype PursuitCompletion = PursuitCompletion (GenCompletion (package :: String))
newtype Modules = Modules (Array String)
newtype Message = Message String

unwrapResponse :: forall a. (DecodeJson a) => String -> Either String a
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      Right result
    _ -> do
      result <- o .? "result"
      Left result

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe
    (Left "ParseError")
    (Right <<< Message)
    (toString json)

instance decodeModules :: DecodeJson Modules where
  decodeJson json = do
    ms <- decodeJson json
    return (Modules (fromJust $ tail (split ", " ms)))

instance decodeCompletion :: DecodeJson Completion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    return (Completion {identifier: identifier, type': type', module': module'})

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    return (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package
      })

error: pathspec 'examples/Main.purs' did not match any file(s) known to git


this is what Transition would be like…

this is what Transition would be like…

…if it could be a separate interface…but then we wouldn’t be able to chain from Selection to Transition cause they’d be different monads, different interpreters etc etc

So they’re going to have to be one monad/interpreter and thus we will lose any type safety related to ordering of scripts. This seems very unsatisfactory but don’t currently know of a better way.

This file will accordingly be deleted again in the next commit and the “methods” rolled into “Selection”

module TaglessD3.Transition where

import Data.List (List)
import Prelude (class Monad, Unit)
import TaglessD3.AttrNew (Attr)
import TaglessD3.Base (D3ElementType, D3Transition, Selector)
import TaglessD3.Selection

class (Monad m) <= AbstractTransition m where
    attrs       :: List Attr     -> (m Unit)
    merge       :: m Unit        -> (m Unit)
    remove      ::                  (m Unit)
    select      :: Selector      -> (m Unit)
    selectAll   :: Selector      -> (m Unit)
    transition  :: D3Transition  -> (m Unit)
-- the following methods on D3's transition are not currently implemented in the tagless version
    -- attrTween
    -- call
    -- d3Interrupt
    -- delay
    -- duration
    -- each
    -- ease
    -- empty
    -- filter
    -- node(s)
    -- on
    -- selection
    -- size
    -- style(s) -- part of attr(s)
    -- styleTween
    -- text
    -- transition
    -- tween

error: pathspec 'src/TaglessD3/Transition.purs' did not match any file(s) known to git


Parse floats correctly, fixes #5

Parse floats correctly, fixes #5

module Insect (
  repl
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)

import Data.Quantity
import Data.Quantity.Math

import Data.Units
import Data.Units.SI
import Data.Units.SI.Derived
import Data.Units.SI.Accepted
import Data.Units.Imperial
import Data.Units.Time
import Data.Units.Bit

import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Maybe
import Data.String

import Global (readFloat, isFinite)

import Partial.Unsafe

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.Expr
import Text.Parsing.StringParser.String

pNumber :: Parser Number
pNumber = do
  intPart <- signAndDigits

  mFracPart <- optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart <- optionMaybe (append <$> string "e" <*> signAndDigits)
  let expPart = fromMaybe "" mExpPart

  let num = readFloat (intPart <> fracPart <> expPart)

  if isFinite num
    then pure num
    else fail "Could not parse Number"

  where
    digits :: Parser String
    digits = do
      ds <- many1 anyDigit
      pure $ fromCharArray (fromFoldable ds)

    signAndDigits :: Parser String
    signAndDigits = do
      sign <- singleton <$> option '+' (oneOf ['+', '-'])
      intPart <- digits
      pure $ sign <> intPart

pPrefix :: Parser (DerivedUnit → DerivedUnit)
pPrefix =
      (string "µ" *> pure micro)
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> pure id

pImperialUnit :: Parser DerivedUnit
pImperialUnit =
      (string "miles" *> pure mile)
  <|> (string "mile"  *> pure mile)
  <|> (string "mph"   *> pure (mile ./ hour))
  <|> (string "in"    *> pure inch)
  <|> (string "ft"    *> pure foot)

pUnit :: Parser DerivedUnit
pUnit =
      (string "sec"   *> pure second)
  <|> (string "min"   *> pure minute)
  <|> (string "hours" *> pure hour)
  <|> (string "hour"  *> pure hour)
  <|> (string "h"     *> pure hour)
  <|> (string "days"  *> pure day)
  <|> (string "day"   *> pure day)
  <|> (string "d"     *> pure day)
  <|> (string "weeks" *> pure week)
  <|> (string "week"  *> pure week)
  <|> (string "m/h"   *> pure (meter ./ hour)) -- TODO
  <|> (string "m/s"   *> pure (meter ./ second)) -- TODO
  <|> (string "g"     *> pure gram)
  <|> (string "m"     *> pure meter)
  <|> (string "s"     *> pure second)
  <?> "Expected unit"

pUnitWithPrefix :: Parser DerivedUnit
pUnitWithPrefix = try withPrefix <|> try pUnit <|> pure unity
  where
    withPrefix = do
      p <- pPrefix
      u <- pUnit
      pure $ p u

pQuantity :: Parser Quantity
pQuantity = quantity <$> pNumber <*> pUnitWithPrefix

qS ea eb = do
  a <- ea
  b <- eb
  a ⊖ b

qA ea eb = do
  a <- ea
  b <- eb
  a ⊕ b

pExpr :: Parser (Either UnificationError Quantity)
pExpr = buildExprParser [ [ Infix (string "/" $> lift2 (⊘)) AssocRight ]
                        , [ Infix (string "*" $> lift2 (⊗)) AssocRight ]
                        , [ Infix (string "-" $> qS) AssocRight ]
                        , [ Infix (string "+" $> qA) AssocRight ]
                        ] (pure <$> pQuantity)

pInput :: Parser (Either UnificationError Quantity)
pInput = try (map toStandard <$> (pExpr <* eof))
  <|> conversion
  where
    conversion = do
      expr <- pExpr
      string " to "
      target <- pUnitWithPrefix
      eof
      pure (expr >>= (flip convertTo) target)

repl :: String -> { out :: String, divClass :: String }
repl inp =
  case runParser pInput inp of
    Left parseErr -> { out: show parseErr, divClass: "error" }
    Right res ->
      case res of
        Left unificationError -> { out: errorMessage unificationError, divClass: "error" }
        Right val -> { out: prettyPrint val, divClass: "value" }

module Insect (
  repl
  ) where

import Prelude

import Control.Monad.Eff (Eff)

import Control.Alt
import Control.Apply

import Data.Quantity
import Data.Units
import Data.Units.SI
import Data.Units.SI.Derived
import Data.Units.Imperial
import Data.Units.Time

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.String
import Text.Parsing.StringParser.Expr
import Data.Either
import Data.Int (fromString, toNumber)
import Data.Foldable
import Data.String
import Data.Maybe
import Data.Array (fromFoldable)
import Partial.Unsafe
import Global (readFloat)

pNumber :: Parser Number
pNumber = do
  nums <- many1 anyDigit
  pure $ readFloat (fromCharArray (fromFoldable nums))

pPrefix :: Parser (DerivedUnit → DerivedUnit)
pPrefix =
      (string "µ" *> pure micro)
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> pure id

pImperialUnit :: Parser DerivedUnit
pImperialUnit =
      (string "miles" *> pure mile)
  <|> (string "mile"  *> pure mile)
  <|> (string "mph"   *> pure (mile ./ hour))
  <|> (string "in"    *> pure inch)
  <|> (string "ft"    *> pure foot)

pUnit :: Parser DerivedUnit
pUnit =
      (string "sec"   *> pure second)
  <|> (string "min"   *> pure minute)
  <|> (string "hours" *> pure hour)
  <|> (string "hour"  *> pure hour)
  <|> (string "h"     *> pure hour)
  <|> (string "days"  *> pure day)
  <|> (string "day"   *> pure day)
  <|> (string "d"     *> pure day)
  <|> (string "weeks" *> pure week)
  <|> (string "week"  *> pure week)
  <|> (string "m/h"   *> pure (meter ./ hour)) -- TODO
  <|> (string "m/s"   *> pure (meter ./ second)) -- TODO
  <|> (string "g"     *> pure gram)
  <|> (string "m"     *> pure meter)
  <|> (string "s"     *> pure second)
  <?> "Expected unit"

pUnitWithPrefix :: Parser DerivedUnit
pUnitWithPrefix = try withPrefix <|> try pUnit <|> pure unity
  where
    withPrefix = do
      p <- pPrefix
      u <- pUnit
      pure $ p u

pQuantity :: Parser Quantity
pQuantity = quantity <$> pNumber <*> pUnitWithPrefix

qS ea eb = do
  a <- ea
  b <- eb
  a ⊖ b

qA ea eb = do
  a <- ea
  b <- eb
  a ⊕ b

pExpr :: Parser (Either UnificationError Quantity)
pExpr = buildExprParser [ [ Infix (string "/" $> lift2 (⊘)) AssocRight ]
                        , [ Infix (string "*" $> lift2 (⊗)) AssocRight ]
                        , [ Infix (string "-" $> qS) AssocRight ]
                        , [ Infix (string "+" $> qA) AssocRight ]
                        ] (pure <$> pQuantity)

pInput :: Parser (Either UnificationError Quantity)
pInput = try (map toStandard <$> (pExpr <* eof))
  <|> conversion
  where
    conversion = do
      expr <- pExpr
      string " to "
      target <- pUnitWithPrefix
      eof
      pure (expr >>= (flip convertTo) target)

repl :: String -> { out :: String, divClass :: String }
repl inp =
  case runParser pInput inp of
    Left parseErr -> { out: show parseErr, divClass: "error" }
    Right res ->
      case res of
        Left unificationError -> { out: errorMessage unificationError, divClass: "error" }
        Right val -> { out: prettyPrint val, divClass: "value" }


Language.PureScript.Optimizer.Inliner partially done

Needs a fix in psc so qualified operator names can be parsed

module Language.PureScript.Optimizer.Inliner
  ( inlineVariables
  , inlineOperator
  , inlineCommonOperators
  , etaConvert
  , unThunk
  , evaluateIifes
  ) where

import Data.Array (map, zipWith)
import Data.Array.Unsafe (last, init)
import Data.Foldable (all, any)
import Data.Maybe
import Data.Tuple
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Names
import Language.PureScript.Optimizer.Common

import qualified Language.PureScript.Constants as C

shouldInline :: JS -> Boolean
shouldInline (JSVar _) = true
shouldInline (JSNumericLiteral _) = true
shouldInline (JSStringLiteral _) = true
shouldInline (JSBooleanLiteral _) = true
shouldInline (JSAccessor _ val) = shouldInline val
shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
shouldInline _ = false

etaConvert :: JS -> JS
etaConvert = everywhereOnJS convert
  where
  convert :: JS -> JS
  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
    | all shouldInline args &&
      not (any (flip isRebound block) (map JSVar idents)) &&
      not (any (flip isRebound block) args)
      = JSBlock (map (replaceIdents (zipWith Tuple idents args)) body)
  convert js = js

unThunk :: JS -> JS
unThunk = everywhereOnJS convert
  where
  convert :: JS -> JS
  convert (JSBlock []) = JSBlock []
  convert (JSBlock jss) =
    case last jss of
      JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
      _ -> JSBlock jss
  convert js = js

evaluateIifes :: JS -> JS
evaluateIifes = everywhereOnJS convert
  where
  convert :: JS -> JS
  convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
  convert js = js

inlineVariables :: JS -> JS
inlineVariables = everywhereOnJS $ removeFromBlock go
  where
  go :: [JS] -> [JS]
  go [] = []
  go (JSVariableIntroduction var (Just js) : sts)
    | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
      go (map (replaceIdent var js) sts)
  go (s:sts) = s : go sts

inlineOperator :: (Tuple String String) -> (JS -> JS -> JS) -> JS -> JS
inlineOperator (Tuple m op) f = everywhereOnJS convert
  where
  convert :: JS -> JS
  convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
  convert other = other
  isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
  isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
  isOp _ = false

inlineCommonOperators :: JS -> JS
inlineCommonOperators = applyAll
  [
    -- binary C.numNumber (C.+) Add
  -- , binary C.numNumber (C.-) Subtract
  -- , binary C.numNumber (C.*) Multiply
  -- , binary C.numNumber (C./) Divide
  -- , binary C.numNumber (C.%) Modulus
  --,
  unary  C.numNumber C.negate Negate

  -- , binary C.ordNumber (C.<) LessThan
  -- , binary C.ordNumber (C.>) GreaterThan
  -- , binary C.ordNumber (C.<=) LessThanOrEqualTo
  -- , binary C.ordNumber (C.>=) GreaterThanOrEqualTo

  -- , binary C.eqNumber (C.==) EqualTo
  -- , binary C.eqNumber (C./=) NotEqualTo
  -- , binary C.eqString (C.==) EqualTo
  -- , binary C.eqString (C./=) NotEqualTo
  -- , binary C.eqBoolean (C.==) EqualTo
  -- , binary C.eqBoolean (C./=) NotEqualTo

  -- , binary C.semigroupString (C.++) Add

  , binaryFunction C.bitsNumber C.shl ShiftLeft
  , binaryFunction C.bitsNumber C.shr ShiftRight
  , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
  -- , binary         C.bitsNumber (C.&) BitwiseAnd
  , binary         C.bitsNumber C.bar BitwiseOr
  -- , binary         C.bitsNumber (C.^) BitwiseXor
  , unary          C.bitsNumber C.complement BitwiseNot

  -- , binary C.boolLikeBoolean (C.&&) And
  -- , binary C.boolLikeBoolean (C.||) Or
  , unary  C.boolLikeBoolean C.not Not
  ]
  where
  binary :: String -> String -> BinaryOperator -> JS -> JS
  binary dictName opString op = everywhereOnJS convert
    where
    convert :: JS -> JS
    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
    convert other = other
    isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)
    isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
    isOp _ = false
  binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
  binaryFunction dictName fnName op = everywhereOnJS convert
    where
    convert :: JS -> JS
    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
    convert other = other
    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
    isOp _ = false
  unary :: String -> String -> UnaryOperator -> JS -> JS
  unary dictName fnName op = everywhereOnJS convert
    where
    convert :: JS -> JS
    convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
    convert other = other
    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
    isOp _ = false
  isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName
  isOpDict _ _ = false

error: pathspec 'src/Language/PureScript/Optimizer/Inliner.purs' did not match any file(s) known to git


4.4.2

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/mikemcgowan/purescript-book.git/'


4.15.1