Added showDayOfMonth instance.

Added showDayOfMonth instance.

module Data.Date
  ( JSDate()
  , Date()
  , fromJSDate
  , toJSDate
  , fromEpochMilliseconds
  , toEpochMilliseconds
  , fromString
  , fromStringStrict
  , Now()
  , now
  , nowEpochMilliseconds
  , LocaleOffset(..)
  , timezoneOffset
  , Year(..)
  , Month(..)
  , DayOfMonth(..)
  , DayOfWeek(..)
  ) where

import Prelude

import Control.Monad.Eff
import Data.Enum (Enum, Cardinality(..), fromEnum, defaultSucc, defaultPred)
import Data.Function (on, Fn2(), runFn2, Fn3(), runFn3)
import Data.Maybe (Maybe(..))
import Data.Time

-- | A native JavaScript `Date` object.
foreign import data JSDate :: *

-- | A combined date/time value. `Date`s cannot be constructed directly to
-- | ensure they are not the `Invalid Date` value, and instead must be created
-- | via `fromJSDate`, `fromEpochMilliseconds`, `fromString`, etc. or the `date`
-- | and `dateTime` functions in the `Data.Date.Locale` and `Data.Date.UTC`
-- | modules.
newtype Date = DateTime JSDate

instance eqDate :: Eq Date where
  eq = eq `on` toEpochMilliseconds

instance ordDate :: Ord Date where
  compare = compare `on` toEpochMilliseconds

instance showDate :: Show Date where
  show d = "(fromEpochMilliseconds " ++ show (toEpochMilliseconds d) ++ ")"

-- | Attempts to create a `Date` from a `JSDate`. If the `JSDate` is an invalid
-- | date `Nothing` is returned.
fromJSDate :: JSDate -> Maybe Date
fromJSDate d =
  if Global.isNaN (runFn2 jsDateMethod "getTime" d)
  then Nothing
  else Just (DateTime d)

-- | Extracts a `JSDate` from a `Date`.
toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

-- | Creates a `Date` value from a number of milliseconds elapsed since 1st
-- | January 1970 00:00:00 UTC.
fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

-- | Gets the number of milliseconds elapsed since 1st January 1970 00:00:00
-- | UTC for a `Date`.
toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds (DateTime d) = runFn2 jsDateMethod "getTime" d

-- | Attempts to construct a date from a string value using JavaScript’s
-- | [Date.parse() method](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/parse).
-- | `Nothing` is returned if the parse fails or the resulting date is invalid.
fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

-- | Attempts to construct a date from a simplified extended ISO 8601 format
-- | (`YYYY-MM-DDTHH:mm:ss.sssZ`). `Nothing` is returned if the format is not
-- | an exact match or the resulting date is invalid.
fromStringStrict :: String -> Maybe Date
fromStringStrict s = runFn3 strictJsDate Just Nothing s >>= fromJSDate

-- | Effect type for when accessing the current date/time.
foreign import data Now :: !

-- | Gets a `Date` value for the current date/time according to the current
-- | machine’s local time.
now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

-- | Gets the number of milliseconds elapsed milliseconds since 1st January
-- | 1970 00:00:00 UTC according to the current machine’s local time
foreign import nowEpochMilliseconds :: forall e. Eff (now :: Now | e) Milliseconds

-- | A timezone locale offset, measured in minutes.
newtype LocaleOffset = LocaleOffset Minutes

-- | Get the locale time offset for a `Date`.
timezoneOffset :: Date -> LocaleOffset
timezoneOffset (DateTime d) = runFn2 jsDateMethod "getTimezoneOffset" d

-- | A year date component value.
newtype Year = Year Int

instance eqYear :: Eq Year where
  eq (Year x) (Year y) = x == y

instance ordYear :: Ord Year where
  compare (Year x) (Year y) = compare x y

instance semiringYear :: Semiring Year where
  add (Year x) (Year y) = Year (x + y)
  mul (Year x) (Year y) = Year (x * y)
  zero = Year zero
  one = Year one

instance ringYear :: Ring Year where
  sub (Year x) (Year y) = Year (x - y)

instance showYear :: Show Year where
  show (Year n) = "(Year " ++ show n ++ ")"

-- | A month date component value.
data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

instance eqMonth :: Eq Month where
  eq January   January   = true
  eq February  February  = true
  eq March     March     = true
  eq April     April     = true
  eq May       May       = true
  eq June      June      = true
  eq July      July      = true
  eq August    August    = true
  eq September September = true
  eq October   October   = true
  eq November  November  = true
  eq December  December  = true
  eq _         _         = false

instance ordMonth :: Ord Month where
  compare = compare `on` fromEnum

instance boundedMonth :: Bounded Month where
  bottom = January
  top = December

instance boundedOrdMonth :: BoundedOrd Month

instance showMonth :: Show Month where
  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumMonth :: Enum Month where
  cardinality = Cardinality 12
  succ = defaultSucc monthToEnum monthFromEnum
  pred = defaultPred monthToEnum monthFromEnum
  toEnum = monthToEnum
  fromEnum = monthFromEnum

monthToEnum :: Int -> Maybe Month
monthToEnum 0  = Just January
monthToEnum 1  = Just February
monthToEnum 2  = Just March
monthToEnum 3  = Just April
monthToEnum 4  = Just May
monthToEnum 5  = Just June
monthToEnum 6  = Just July
monthToEnum 7  = Just August
monthToEnum 8  = Just September
monthToEnum 9  = Just October
monthToEnum 10 = Just November
monthToEnum 11 = Just December
monthToEnum _  = Nothing

monthFromEnum :: Month -> Int
monthFromEnum January   = 0
monthFromEnum February  = 1
monthFromEnum March     = 2
monthFromEnum April     = 3
monthFromEnum May       = 4
monthFromEnum June      = 5
monthFromEnum July      = 6
monthFromEnum August    = 7
monthFromEnum September = 8
monthFromEnum October   = 9
monthFromEnum November  = 10
monthFromEnum December  = 11

-- | A day-of-month date component value.
newtype DayOfMonth = DayOfMonth Int

instance eqDayOfMonth :: Eq DayOfMonth where
  eq (DayOfMonth x) (DayOfMonth y) = x == y

instance ordDayOfMonth :: Ord DayOfMonth where
  compare (DayOfMonth x) (DayOfMonth y) = compare x y

instance showDayOfMonth :: Show DayOfMonth where
  show (DayOfMonth day) = "(DayOfMonth " ++ show day ++ ")"

-- | A day-of-week date component value.
data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

instance eqDayOfWeek :: Eq DayOfWeek where
  eq Sunday    Sunday    = true
  eq Monday    Monday    = true
  eq Tuesday   Tuesday   = true
  eq Wednesday Wednesday = true
  eq Thursday  Thursday  = true
  eq Friday    Friday    = true
  eq Saturday  Saturday  = true
  eq _         _         = false

instance ordDayOfWeek :: Ord DayOfWeek where
  compare = compare `on` fromEnum

instance boundedDayOfWeek :: Bounded DayOfWeek where
  bottom = Sunday
  top = Saturday

instance boundedOrdDayOfWeek :: BoundedOrd DayOfWeek

instance showDayOfWeek :: Show DayOfWeek where
  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

instance enumDayOfWeek :: Enum DayOfWeek where
  cardinality = Cardinality 7
  succ = defaultSucc dayOfWeekToEnum dayOfWeekFromEnum
  pred = defaultPred dayOfWeekToEnum dayOfWeekFromEnum
  toEnum = dayOfWeekToEnum
  fromEnum = dayOfWeekFromEnum

dayOfWeekToEnum :: Int -> Maybe DayOfWeek
dayOfWeekToEnum 0 = Just Sunday
dayOfWeekToEnum 1 = Just Monday
dayOfWeekToEnum 2 = Just Tuesday
dayOfWeekToEnum 3 = Just Wednesday
dayOfWeekToEnum 4 = Just Thursday
dayOfWeekToEnum 5 = Just Friday
dayOfWeekToEnum 6 = Just Saturday
dayOfWeekToEnum _ = Nothing

dayOfWeekFromEnum :: DayOfWeek -> Int
dayOfWeekFromEnum Sunday    = 0
dayOfWeekFromEnum Monday    = 1
dayOfWeekFromEnum Tuesday   = 2
dayOfWeekFromEnum Wednesday = 3
dayOfWeekFromEnum Thursday  = 4
dayOfWeekFromEnum Friday    = 5
dayOfWeekFromEnum Saturday  = 6

foreign import nowImpl :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

foreign import jsDateConstructor :: forall a. a -> JSDate

foreign import jsDateMethod :: forall a. Fn2 String JSDate a

foreign import strictJsDate :: Fn3 (forall a. a -> Maybe a) (forall a. Maybe a) String (Maybe JSDate)

module Data.Date
  ( JSDate()
  , Date()
  , fromJSDate
  , toJSDate
  , fromEpochMilliseconds
  , toEpochMilliseconds
  , fromString
  , fromStringStrict
  , Now()
  , now
  , nowEpochMilliseconds
  , LocaleOffset(..)
  , timezoneOffset
  , Year(..)
  , Month(..)
  , DayOfMonth(..)
  , DayOfWeek(..)
  ) where

import Prelude

import Control.Monad.Eff
import Data.Enum (Enum, Cardinality(..), fromEnum, defaultSucc, defaultPred)
import Data.Function (on, Fn2(), runFn2, Fn3(), runFn3)
import Data.Maybe (Maybe(..))
import Data.Time

-- | A native JavaScript `Date` object.
foreign import data JSDate :: *

-- | A combined date/time value. `Date`s cannot be constructed directly to
-- | ensure they are not the `Invalid Date` value, and instead must be created
-- | via `fromJSDate`, `fromEpochMilliseconds`, `fromString`, etc. or the `date`
-- | and `dateTime` functions in the `Data.Date.Locale` and `Data.Date.UTC`
-- | modules.
newtype Date = DateTime JSDate

instance eqDate :: Eq Date where
  eq = eq `on` toEpochMilliseconds

instance ordDate :: Ord Date where
  compare = compare `on` toEpochMilliseconds

instance showDate :: Show Date where
  show d = "(fromEpochMilliseconds " ++ show (toEpochMilliseconds d) ++ ")"

-- | Attempts to create a `Date` from a `JSDate`. If the `JSDate` is an invalid
-- | date `Nothing` is returned.
fromJSDate :: JSDate -> Maybe Date
fromJSDate d =
  if Global.isNaN (runFn2 jsDateMethod "getTime" d)
  then Nothing
  else Just (DateTime d)

-- | Extracts a `JSDate` from a `Date`.
toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

-- | Creates a `Date` value from a number of milliseconds elapsed since 1st
-- | January 1970 00:00:00 UTC.
fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

-- | Gets the number of milliseconds elapsed since 1st January 1970 00:00:00
-- | UTC for a `Date`.
toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds (DateTime d) = runFn2 jsDateMethod "getTime" d

-- | Attempts to construct a date from a string value using JavaScript’s
-- | [Date.parse() method](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/parse).
-- | `Nothing` is returned if the parse fails or the resulting date is invalid.
fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

-- | Attempts to construct a date from a simplified extended ISO 8601 format
-- | (`YYYY-MM-DDTHH:mm:ss.sssZ`). `Nothing` is returned if the format is not
-- | an exact match or the resulting date is invalid.
fromStringStrict :: String -> Maybe Date
fromStringStrict s = runFn3 strictJsDate Just Nothing s >>= fromJSDate

-- | Effect type for when accessing the current date/time.
foreign import data Now :: !

-- | Gets a `Date` value for the current date/time according to the current
-- | machine’s local time.
now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

-- | Gets the number of milliseconds elapsed milliseconds since 1st January
-- | 1970 00:00:00 UTC according to the current machine’s local time
foreign import nowEpochMilliseconds :: forall e. Eff (now :: Now | e) Milliseconds

-- | A timezone locale offset, measured in minutes.
newtype LocaleOffset = LocaleOffset Minutes

-- | Get the locale time offset for a `Date`.
timezoneOffset :: Date -> LocaleOffset
timezoneOffset (DateTime d) = runFn2 jsDateMethod "getTimezoneOffset" d

-- | A year date component value.
newtype Year = Year Int

instance eqYear :: Eq Year where
  eq (Year x) (Year y) = x == y

instance ordYear :: Ord Year where
  compare (Year x) (Year y) = compare x y

instance semiringYear :: Semiring Year where
  add (Year x) (Year y) = Year (x + y)
  mul (Year x) (Year y) = Year (x * y)
  zero = Year zero
  one = Year one

instance ringYear :: Ring Year where
  sub (Year x) (Year y) = Year (x - y)

instance showYear :: Show Year where
  show (Year n) = "(Year " ++ show n ++ ")"

-- | A month date component value.
data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

instance eqMonth :: Eq Month where
  eq January   January   = true
  eq February  February  = true
  eq March     March     = true
  eq April     April     = true
  eq May       May       = true
  eq June      June      = true
  eq July      July      = true
  eq August    August    = true
  eq September September = true
  eq October   October   = true
  eq November  November  = true
  eq December  December  = true
  eq _         _         = false

instance ordMonth :: Ord Month where
  compare = compare `on` fromEnum

instance boundedMonth :: Bounded Month where
  bottom = January
  top = December

instance boundedOrdMonth :: BoundedOrd Month

instance showMonth :: Show Month where
  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumMonth :: Enum Month where
  cardinality = Cardinality 12
  succ = defaultSucc monthToEnum monthFromEnum
  pred = defaultPred monthToEnum monthFromEnum
  toEnum = monthToEnum
  fromEnum = monthFromEnum

monthToEnum :: Int -> Maybe Month
monthToEnum 0  = Just January
monthToEnum 1  = Just February
monthToEnum 2  = Just March
monthToEnum 3  = Just April
monthToEnum 4  = Just May
monthToEnum 5  = Just June
monthToEnum 6  = Just July
monthToEnum 7  = Just August
monthToEnum 8  = Just September
monthToEnum 9  = Just October
monthToEnum 10 = Just November
monthToEnum 11 = Just December
monthToEnum _  = Nothing

monthFromEnum :: Month -> Int
monthFromEnum January   = 0
monthFromEnum February  = 1
monthFromEnum March     = 2
monthFromEnum April     = 3
monthFromEnum May       = 4
monthFromEnum June      = 5
monthFromEnum July      = 6
monthFromEnum August    = 7
monthFromEnum September = 8
monthFromEnum October   = 9
monthFromEnum November  = 10
monthFromEnum December  = 11

-- | A day-of-month date component value.
newtype DayOfMonth = DayOfMonth Int

instance eqDayOfMonth :: Eq DayOfMonth where
  eq (DayOfMonth x) (DayOfMonth y) = x == y

instance ordDayOfMonth :: Ord DayOfMonth where
  compare (DayOfMonth x) (DayOfMonth y) = compare x y

-- | A day-of-week date component value.
data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

instance eqDayOfWeek :: Eq DayOfWeek where
  eq Sunday    Sunday    = true
  eq Monday    Monday    = true
  eq Tuesday   Tuesday   = true
  eq Wednesday Wednesday = true
  eq Thursday  Thursday  = true
  eq Friday    Friday    = true
  eq Saturday  Saturday  = true
  eq _         _         = false

instance ordDayOfWeek :: Ord DayOfWeek where
  compare = compare `on` fromEnum

instance boundedDayOfWeek :: Bounded DayOfWeek where
  bottom = Sunday
  top = Saturday

instance boundedOrdDayOfWeek :: BoundedOrd DayOfWeek

instance showDayOfWeek :: Show DayOfWeek where
  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

instance enumDayOfWeek :: Enum DayOfWeek where
  cardinality = Cardinality 7
  succ = defaultSucc dayOfWeekToEnum dayOfWeekFromEnum
  pred = defaultPred dayOfWeekToEnum dayOfWeekFromEnum
  toEnum = dayOfWeekToEnum
  fromEnum = dayOfWeekFromEnum

dayOfWeekToEnum :: Int -> Maybe DayOfWeek
dayOfWeekToEnum 0 = Just Sunday
dayOfWeekToEnum 1 = Just Monday
dayOfWeekToEnum 2 = Just Tuesday
dayOfWeekToEnum 3 = Just Wednesday
dayOfWeekToEnum 4 = Just Thursday
dayOfWeekToEnum 5 = Just Friday
dayOfWeekToEnum 6 = Just Saturday
dayOfWeekToEnum _ = Nothing

dayOfWeekFromEnum :: DayOfWeek -> Int
dayOfWeekFromEnum Sunday    = 0
dayOfWeekFromEnum Monday    = 1
dayOfWeekFromEnum Tuesday   = 2
dayOfWeekFromEnum Wednesday = 3
dayOfWeekFromEnum Thursday  = 4
dayOfWeekFromEnum Friday    = 5
dayOfWeekFromEnum Saturday  = 6

foreign import nowImpl :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

foreign import jsDateConstructor :: forall a. a -> JSDate

foreign import jsDateMethod :: forall a. Fn2 String JSDate a

foreign import strictJsDate :: Fn3 (forall a. a -> Maybe a) (forall a. Maybe a) String (Maybe JSDate)


Clean up Track config, improve errors

Clean up Track config, improve errors

module Genetics.Browser.Config.Track
       ( BDTrackConfig
       , CyGraphConfig
       , TracksMap
       , validateConfigs
       , TrackType(..)
       , readTrackType
       , validateBDConfig
       , validateCyConfig
       , readTracksMap
       )
       where

import Prelude

import Control.Monad.Except (throwError)
import Data.Argonaut (Json, _Array, _Object, _String)
import Data.Array ((:))
import Data.Either (Either(..))
import Data.Foldable (all, foldr, null)
import Data.Foreign (F, Foreign, ForeignError(..), fail)
import Data.Foreign.Keys (keys)
import Data.Generic.Rep (class Generic)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), isJust, isNothing, maybe)
import Data.Newtype (class Newtype)
import Data.StrMap (StrMap)
import Data.Traversable (sequence)
import Unsafe.Coerce (unsafeCoerce)

-- | Contains arrays of track configurations, inedxed by track types (e.g. BD or Cy)
newtype TracksMap = TracksMap (StrMap Json)

getConfigs :: TracksMap -> TrackType -> Either String (Array Json)
getConfigs (TracksMap ts) tt = case ts ^? ix (show tt) <<< _Array of
  Nothing -> throwError "Incorrect trackType"
  Just ar -> pure ar

-- | The different types of track configuration
data TrackType = BDTrack | CyGraph

derive instance eqTrackType :: Eq TrackType
derive instance ordTrackType :: Ord TrackType
derive instance genericTrackType :: Generic TrackType _

instance showTrackType :: Show TrackType where
  show BDTrack = "BDTrack"
  show CyGraph = "CyGraph"

readTrackType :: String -> Maybe TrackType
readTrackType "BDTrack" = Just BDTrack
readTrackType "CyGraph" = Just CyGraph
readTrackType _ = Nothing

-- | Represents a Biodalliance track configuration
newtype BDTrackConfig = BDTrackConfig Json

-- | Validate a Biodalliance track configuration; currently only checks for the presence of a name
validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json = case json ^? _Object of
  Nothing -> throwError "BD track config is not Object"
  Just obj -> do
    let name = obj ^? ix "name" <<< _String
    when (isNothing name) do
      throwError "BD track config does not have a name"

    pure $ BDTrackConfig json

-- | Represents a Cytoscape.js graph configuration
newtype CyGraphConfig = CyGraphConfig { elementsUri :: String
                                      , name :: String }
derive instance newtypeCyGraphConfig :: Newtype CyGraphConfig _

-- | Validate a Cytoscape.js graph configuration; currently only checks for the presence of a URI
-- | to some JSON-formatted elements
validateCyConfig :: Json -> Either String CyGraphConfig
validateCyConfig json = case json ^? _Object of
  Nothing -> throwError "Cy graph config is not Object"
  Just obj -> do

    name <- case obj ^? ix "name" <<< _String of
      Nothing -> throwError "Cy graph config does not have a name"
      Just n -> pure n

    uri <- case obj ^? ix "elementsUri"  <<< _String of
      Nothing -> throwError "Cy graph config does not have an elementsUri"
      Just u -> pure u

    pure $ CyGraphConfig { elementsUri: uri, name }

type ValidatedConfigs a = { errors :: Array String
                          , results :: Array a
                          }

foldErrors :: forall e r
            . Array (Either e r)
           -> { errors :: Array e
              , results :: Array r
              }
foldErrors = foldr (\c er@{errors, results} ->
                                case c of Left  e -> er { errors  = (e : errors)}
                                          Right r -> er { results = (r : results)}
                   ) { errors: [], results: [] }

foldConfig :: forall a
             . TracksMap
            -> TrackType
            -> (Json -> Either String a)
            -> ValidatedConfigs a
foldConfig tm tt f = foldErrors $ map (_ >>= f) $ sequence $ getConfigs tm tt

-- | Given a TracksMap of configurations,
-- | Returns the validated configurations and any errors, indexed by track type
validateConfigs :: TracksMap
                -> { bdTracks :: ValidatedConfigs BDTrackConfig
                   , cyGraphs :: ValidatedConfigs CyGraphConfig
                   }
validateConfigs tm = { bdTracks
                     , cyGraphs
                     }
  where bdTracks = foldConfig tm BDTrack validateBDConfig
        cyGraphs = foldConfig tm CyGraph validateCyConfig

readTracksMap :: Foreign -> F TracksMap
readTracksMap f = do
  tracksKeys <- (map readTrackType) <$> keys f
  when (null tracksKeys) $ fail $ ForeignError "TracksMap is empty"
  when (not $ all isJust tracksKeys) $ fail $ ForeignError "TracksMap keys are not all TrackType"
  pure $ unsafeCoerce f

module Genetics.Browser.Config.Track
       ( BDTrackConfig
       , CyGraphConfig
       , TracksMap
       , validateConfigs
       , TrackType(..)
       , readTrackType
       , validateBDConfig
       , validateCyConfig
       , readTracksMap
       )
       where

import Prelude

import Data.Argonaut (Json, _Array, _Object, _String)
import Data.Array ((:))
import Data.Either (Either(..))
import Data.Foldable (all, foldr, null)
import Data.Foreign (F, Foreign, ForeignError(..), fail)
import Data.Foreign.Keys (keys)
import Data.Generic.Rep (class Generic)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Newtype (class Newtype)
import Data.StrMap (StrMap)
import Data.Traversable (sequence)
import Unsafe.Coerce (unsafeCoerce)

-- | Contains arrays of track configurations, inedxed by track types (e.g. BD or Cy)
newtype TracksMap = TracksMap (StrMap Json)

getConfigs :: TracksMap -> TrackType -> Either String (Array Json)
getConfigs (TracksMap ts) tt =
  maybe (Left "Incorrect trackType") Right $ ts ^? ix (show tt) <<< _Array

-- | The different types of track configuration
data TrackType = BDTrack | CyGraph

derive instance eqTrackType :: Eq TrackType
derive instance ordTrackType :: Ord TrackType
derive instance genericTrackType :: Generic TrackType _

instance showTrackType :: Show TrackType where
  show BDTrack = "BDTrack"
  show CyGraph = "CyGraph"

readTrackType :: String -> Maybe TrackType
readTrackType "BDTrack" = Just BDTrack
readTrackType "CyGraph" = Just CyGraph
readTrackType _ = Nothing

-- TODO: combine validateBDConfig and validateCyConfig
-- validateTrackConfig :: Json -> Either String (Either BDTrackConfig CyGraphConfig)
-- validateTrackConfig :: Json -> Either String (Either3 BDTrackConfig PSTrackConfig CyGraphConfig)

-- | Represents a Biodalliance track configuration
newtype BDTrackConfig = BDTrackConfig Json

-- | Validate a Biodalliance track configuration; currently only checks for the presence of a name
validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json = case json ^? _Object <<< ix "name" of
  Nothing -> Left $ "BD track config does not have a name"
  Just c  -> Right $ BDTrackConfig $ json

-- | Represents a Cytoscape.js graph configuration
newtype CyGraphConfig = CyGraphConfig { elementsUri :: String }
derive instance newtypeCyGraphConfig :: Newtype CyGraphConfig _

-- | Validate a Cytoscape.js graph configuration; currently only checks for the presence of a URI
-- | to some JSON-formatted elements
validateCyConfig :: Json -> Either String CyGraphConfig
validateCyConfig json = case json ^? _Object <<< ix "elementsUri"  <<< _String of
  Nothing  -> Left $ "cy graph config does not have an elementsUri"
  Just uri -> Right $ CyGraphConfig { elementsUri: uri }

type ValidatedConfigs a = { errors :: Array String
                          , results :: Array a
                          }

foldErrors :: forall e r
            . Array (Either e r)
           -> { errors :: Array e
              , results :: Array r
              }
foldErrors = foldr (\c er@{errors, results} ->
                                case c of Left  e -> er { errors  = (e : errors)}
                                          Right r -> er { results = (r : results)}
                   ) { errors: [], results: [] }

foldConfig :: forall a
             . TracksMap
            -> TrackType
            -> (Json -> Either String a)
            -> ValidatedConfigs a
foldConfig tm tt f = foldErrors $ map (_ >>= f) $ sequence $ getConfigs tm tt

-- | Given a TracksMap of configurations,
-- | Returns the validated configurations and any errors, indexed by track type
validateConfigs :: TracksMap
                -> { bdTracks :: ValidatedConfigs BDTrackConfig
                   , cyGraphs :: ValidatedConfigs CyGraphConfig
                   }
validateConfigs tm = { bdTracks
                     , cyGraphs
                     }
  where bdTracks = foldConfig tm BDTrack validateBDConfig
        cyGraphs = foldConfig tm CyGraph validateCyConfig

readTracksMap :: Foreign -> F TracksMap
readTracksMap f = do
  tracksKeys <- (map readTrackType) <$> keys f
  when (null tracksKeys) $ fail $ ForeignError "TracksMap is empty"
  when (not $ all isJust tracksKeys) $ fail $ ForeignError "TracksMap keys are not all TrackType"
  pure $ unsafeCoerce f


Removes unnecessary type variable from docstring


Nicer button styling

Nicer button styling


Re-inject partial short options

Re-inject partial short options

Given an short option as input, parse the input, resulting in a
`Value` for each matched `Option` from the specification:

    (Argument, Value)

However, because of the ambiguity of short options, we modify the
parser by re-injecting the unparsed rest (the remainder) of the
short option back onto the input stream. This allows to repeatedly
parse pieces of the input until it is fully consumed or we fail.
This, the return value must be:

    (Maybe Token, Maybe (Argument, Value))


Fix `scalePairBy` in Coordinates

Fix `scalePairBy` in Coordinates

module Genetics.Browser.Types.Coordinates where

import Prelude

import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (any, foldMap)
import Data.Generic.Rep (class Generic)
import Data.Lens (Getter', Lens, _2, findOf, folded, to, view, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF)
import Data.Pair (Pair(..))
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Types (Point)

-- | The global coordinate system works by taking the sum of the chromosome sizes,
-- | for now mainly represented as a BigInt, as an Int representation may overflow.
-- | Subsets of the global coordinate system are defined by some interval, namely a Pair of Ints

-- | Helper function to calculate the size of the stretch covered by a pair.
pairSize :: forall c.
            Ring c
         => Pair c
         -> c
pairSize (Pair l r) = r - l

-- | Helper function for defining predicates on pairs that contain a given point.
inPair :: forall c.
          Ord c
       => c
       -> Pair c
       -> Boolean
inPair p (Pair l r) = l <= p && p <= r

-- TODO test this one

-- | Helper function for defining predicates on pairs that overlap with a given pair.
pairsOverlap :: forall c.
                Ord c
             => Pair c
             -> Pair c
             -> Boolean
pairsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

-- | Newtype for representing values normalized to fit in some range
newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint s {x, y} = Normalized { x: x', y: y' }
  where x' = x / s.width
        y' = y / s.height

rescalePoint :: { width :: Number, height :: Number }
             -> Normalized Point
             -> Point
rescalePoint s (Normalized p) = {x: p.x * s.width, y: p.y * s.height}

-- this should be in the UI, actually.
-- the padding for the view is calculated from the current scale & is in [minPixels, maxPixels]
type SegmentPadding = { minPixels :: Number
                      , maxPixels :: Number }

-- | A coordinate system is defined by a set of segments,
-- | which are defined by (mutually exclusive and contiguous) intervals
-- | over the browser coordinates (BigInt in most cases)
newtype CoordSys i c =
  CoordSys (Segments i c)

-- | A single segment is the segment identifier together with the range it covers.
type Segment i c  = Tuple i (Pair c)

-- TODO the `Map i (Pair c)` definition of `Segments i c` makes it
--      tricky to work with `Segments` using lenses; having problems
--      working with whole `Tuple i (Pair c)` from `Map i (Pair c)`
--      without using Map.toUnfoldable, which requires an annotation...

-- | Several segments are indexed by their identifiers.
type Segments i c = Map i (Pair c)

-- | The `Functor` instance maps over the segment borders.
instance functorCoordSys :: Functor (CoordSys i) where
  map f (CoordSys cs) = CoordSys $ (map <<< map) f cs

derive instance newtypeCoordSys :: Newtype (CoordSys i c) _
derive instance genericCoordSys :: Generic (CoordSys i c) _

-- | Lens to the segments in a coordinate system.
_Segments :: forall i c j d.
             Lens
             (CoordSys i c) (CoordSys j d)
             (Segments i c) (Segments j d)
_Segments = _Newtype

-- | A Getter' to retrieve the total size of the coordinate system by summing its parts.
_TotalSize :: forall i c.
              Ring c
           => Getter' (CoordSys i c) c
_TotalSize = _Segments
             <<< (to $ alaF Additive foldMap pairSize)

-- | A Getter' into the size of a segment.
_SegmentSize :: forall i c.
                Ring c
             => Getter' (Segment i c) c
_SegmentSize = _2 <<< to pairSize

-- | A coordinate system is created by providing an array of pairs of
-- | chromosome/segment name (often in the ChrId newtype) and their
-- | respective sizes.
coordSys :: forall i c.
            Ord i
         => Semiring c
         => Array (Tuple i c)
         -> CoordSys i c
coordSys segs = CoordSys $ Map.fromFoldable
                $ Array.zip ids (offsets sizes)
  where (Tuple ids sizes) = Array.unzip segs

        -- Given an array of sizes, produce an array of contiguous intervals.
        offsets :: Array c -> Array (Pair c)
        offsets xs = let os = Array.scanl (\x y -> x + y) zero xs
                     in Array.zipWith Pair (zero `Array.cons` os) os

-- | Given a coordinate system and a point, find the segment that contains the point, if any.
lookupSegment :: forall i c.
                 Ord c
              => CoordSys i c
              -> c
              -> Maybe (Segment i c)
lookupSegment cs x = findOf folded pred array
  where pred :: Segment i c -> Boolean
        pred = view (_2 <<< to (inPair x))
        array :: Array (Segment i c)
        array = cs ^. _Segments <<< to Map.toUnfoldable

-- | Given a coordinate system and a range, find the segments that overlap, even partially, with the range.
segmentsInPair :: forall i c.
                  Ord i
               => Ord c
               => CoordSys i c
               -> Pair c
               -> Segments i c
segmentsInPair cs x = Map.filter (any (_ `inPair` x)) $ cs ^. _Segments

-- | The scale of the browser view is defined by how much of the coordinate system is visible,
-- | and how big the screen it must fit into.
type Scale = { screenWidth :: Number, viewWidth :: BigInt }

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point in the coordinate system
-- | to the screen.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToScreen :: Scale
              -> BigInt
              -> Number
scaleToScreen {screenWidth, viewWidth} x =
  BigInt.toNumber x * (screenWidth / (BigInt.toNumber viewWidth))

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point given in pixels from the left-hand edge
-- | to browser units from the beginning of the browser.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToGlobal :: Scale
              -> Number
              -> BigInt
scaleToGlobal {screenWidth, viewWidth} x =
  BigInt.fromNumber $ x * ((BigInt.toNumber viewWidth) / screenWidth)

-- | Given a coordinate system and browser scale,
-- | return the browser segments scaled to canvas coordinates.
scaledSegments :: forall i.
                  CoordSys i BigInt
               -> Scale
               -> Segments i Number
scaledSegments cs scale = (map <<< map) (scaleToScreen scale) $ cs ^. _Segments

-- | Helper functions for translating and scaling pairs.
-- | They're concretized to `BigInt` for convenience; in truth they would
-- | probably fit better in the UI module.

-- | Translate an BigInt pair to the right by `x` multiples of its size.
translatePairBy :: Pair BigInt
                -> Number
                -> Pair BigInt
translatePairBy p x = (_ + delta) <$> p
  where delta = BigInt.fromNumber $ x * (BigInt.toNumber $ pairSize p)

-- | Scale an Int pair by changing its radius to be `x` times the pair size.
scalePairBy :: Pair BigInt
            -> Number
            -> Pair BigInt
scalePairBy p x = BigInt.fromNumber <$> Pair (l' - delta) (r' + delta)
  where p'@(Pair l' r') = BigInt.toNumber <$> p
        delta = ((pairSize p' * x) - (pairSize p')) / 2.0

module Genetics.Browser.Types.Coordinates where

import Prelude

import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (any, foldMap)
import Data.Generic.Rep (class Generic)
import Data.Lens (Getter', Lens, _2, findOf, folded, to, view, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF)
import Data.Pair (Pair(..))
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Types (Point)

-- | The global coordinate system works by taking the sum of the chromosome sizes,
-- | for now mainly represented as a BigInt, as an Int representation may overflow.
-- | Subsets of the global coordinate system are defined by some interval, namely a Pair of Ints

-- | Helper function to calculate the size of the stretch covered by a pair.
pairSize :: forall c.
            Ring c
         => Pair c
         -> c
pairSize (Pair l r) = r - l

-- | Helper function for defining predicates on pairs that contain a given point.
inPair :: forall c.
          Ord c
       => c
       -> Pair c
       -> Boolean
inPair p (Pair l r) = l <= p && p <= r

-- TODO test this one

-- | Helper function for defining predicates on pairs that overlap with a given pair.
pairsOverlap :: forall c.
                Ord c
             => Pair c
             -> Pair c
             -> Boolean
pairsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

-- | Newtype for representing values normalized to fit in some range
newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint s {x, y} = Normalized { x: x', y: y' }
  where x' = x / s.width
        y' = y / s.height

rescalePoint :: { width :: Number, height :: Number }
             -> Normalized Point
             -> Point
rescalePoint s (Normalized p) = {x: p.x * s.width, y: p.y * s.height}

-- this should be in the UI, actually.
-- the padding for the view is calculated from the current scale & is in [minPixels, maxPixels]
type SegmentPadding = { minPixels :: Number
                      , maxPixels :: Number }

-- | A coordinate system is defined by a set of segments,
-- | which are defined by (mutually exclusive and contiguous) intervals
-- | over the browser coordinates (BigInt in most cases)
newtype CoordSys i c =
  CoordSys (Segments i c)

-- | A single segment is the segment identifier together with the range it covers.
type Segment i c  = Tuple i (Pair c)

-- TODO the `Map i (Pair c)` definition of `Segments i c` makes it
--      tricky to work with `Segments` using lenses; having problems
--      working with whole `Tuple i (Pair c)` from `Map i (Pair c)`
--      without using Map.toUnfoldable, which requires an annotation...

-- | Several segments are indexed by their identifiers.
type Segments i c = Map i (Pair c)

-- | The `Functor` instance maps over the segment borders.
instance functorCoordSys :: Functor (CoordSys i) where
  map f (CoordSys cs) = CoordSys $ (map <<< map) f cs

derive instance newtypeCoordSys :: Newtype (CoordSys i c) _
derive instance genericCoordSys :: Generic (CoordSys i c) _

-- | Lens to the segments in a coordinate system.
_Segments :: forall i c j d.
             Lens
             (CoordSys i c) (CoordSys j d)
             (Segments i c) (Segments j d)
_Segments = _Newtype

-- | A Getter' to retrieve the total size of the coordinate system by summing its parts.
_TotalSize :: forall i c.
              Ring c
           => Getter' (CoordSys i c) c
_TotalSize = _Segments
             <<< (to $ alaF Additive foldMap pairSize)

-- | A Getter' into the size of a segment.
_SegmentSize :: forall i c.
                Ring c
             => Getter' (Segment i c) c
_SegmentSize = _2 <<< to pairSize

-- | A coordinate system is created by providing an array of pairs of
-- | chromosome/segment name (often in the ChrId newtype) and their
-- | respective sizes.
coordSys :: forall i c.
            Ord i
         => Semiring c
         => Array (Tuple i c)
         -> CoordSys i c
coordSys segs = CoordSys $ Map.fromFoldable
                $ Array.zip ids (offsets sizes)
  where (Tuple ids sizes) = Array.unzip segs

        -- Given an array of sizes, produce an array of contiguous intervals.
        offsets :: Array c -> Array (Pair c)
        offsets xs = let os = Array.scanl (\x y -> x + y) zero xs
                     in Array.zipWith Pair (zero `Array.cons` os) os

-- | Given a coordinate system and a point, find the segment that contains the point, if any.
lookupSegment :: forall i c.
                 Ord c
              => CoordSys i c
              -> c
              -> Maybe (Segment i c)
lookupSegment cs x = findOf folded pred array
  where pred :: Segment i c -> Boolean
        pred = view (_2 <<< to (inPair x))
        array :: Array (Segment i c)
        array = cs ^. _Segments <<< to Map.toUnfoldable

-- | Given a coordinate system and a range, find the segments that overlap, even partially, with the range.
segmentsInPair :: forall i c.
                  Ord i
               => Ord c
               => CoordSys i c
               -> Pair c
               -> Segments i c
segmentsInPair cs x = Map.filter (any (_ `inPair` x)) $ cs ^. _Segments

-- | The scale of the browser view is defined by how much of the coordinate system is visible,
-- | and how big the screen it must fit into.
type Scale = { screenWidth :: Number, viewWidth :: BigInt }

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point in the coordinate system
-- | to the screen.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToScreen :: Scale
              -> BigInt
              -> Number
scaleToScreen {screenWidth, viewWidth} x =
  BigInt.toNumber x * (screenWidth / (BigInt.toNumber viewWidth))

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point given in pixels from the left-hand edge
-- | to browser units from the beginning of the browser.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToGlobal :: Scale
              -> Number
              -> BigInt
scaleToGlobal {screenWidth, viewWidth} x =
  BigInt.fromNumber $ x * ((BigInt.toNumber viewWidth) / screenWidth)

-- | Given a coordinate system and browser scale,
-- | return the browser segments scaled to canvas coordinates.
scaledSegments :: forall i.
                  CoordSys i BigInt
               -> Scale
               -> Segments i Number
scaledSegments cs scale = (map <<< map) (scaleToScreen scale) $ cs ^. _Segments

-- | Helper functions for translating and scaling pairs.
-- | They're concretized to `BigInt` for convenience; in truth they would
-- | probably fit better in the UI module.

-- | Translate an BigInt pair to the right by `x` multiples of its size.
translatePairBy :: Pair BigInt
                -> Number
                -> Pair BigInt
translatePairBy p x = (_ + delta) <$> p
  where delta = BigInt.fromNumber $ x * (BigInt.toNumber $ pairSize p)

-- | Scale an Int pair by changing its radius to be `x` times the pair size.
scalePairBy :: Pair BigInt
            -> Number
            -> Pair BigInt
scalePairBy p x = BigInt.fromNumber <$> Pair (l' - delta) (r' + delta)
  where p'@(Pair l' r') = BigInt.toNumber <$> p
        delta = (pairSize p' * x) - (pairSize p') / 2.0


Fix bug in codegen

Fix bug in codegen

module Language.PureScript.CodeGen.Common where

import Data.Array (concatMap, map)
import Data.Foldable (all, elem, foldMap)
import Data.Monoid ()
import Data.String (charCodeAt, joinWith, split)
import Data.String.Regex (Regex(..), regex, test)
import Language.PureScript.Names

-- |
-- Convert an Ident into a valid Javascript identifier:
--
--  * Alphanumeric characters are kept unmodified.
--
--  * Reserved javascript identifiers are prefixed with '$$'.
--
--  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
--
identToJs :: Ident -> String
identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
identToJs (Ident name) = foldMap identCharToString (split "" name)
identToJs (Op op) = foldMap identCharToString (split "" op)

-- |
-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
-- ordinal value.
--
identCharToString :: String -> String
identCharToString c | test rxAlphaNum c = c
identCharToString "_" = "_"
identCharToString "." = "$dot"
identCharToString "$" = "$dollar"
identCharToString "~" = "$tilde"
identCharToString "=" = "$eq"
identCharToString "<" = "$less"
identCharToString ">" = "$greater"
identCharToString "!" = "$bang"
identCharToString "#" = "$hash"
identCharToString "%" = "$percent"
identCharToString "^" = "$up"
identCharToString "&" = "$amp"
identCharToString "|" = "$bar"
identCharToString "*" = "$times"
identCharToString "/" = "$div"
identCharToString "+" = "$plus"
identCharToString "-" = "$minus"
identCharToString ":" = "$colon"
identCharToString "\\" = "$bslash"
identCharToString "?" = "$qmark"
identCharToString "@" = "$at"
identCharToString "\'" = "$prime"
identCharToString c = "$" ++ show (charCodeAt 0 c)

-- |
-- Checks whether an identifier name is reserved in Javascript.
--
nameIsJsReserved :: String -> Boolean
nameIsJsReserved name =
  name `elem` [ "abstract"
              , "arguments"
              , "boolean"
              , "break"
              , "byte"
              , "case"
              , "catch"
              , "char"
              , "class"
              , "const"
              , "continue"
              , "debugger"
              , "default"
              , "delete"
              , "do"
              , "double"
              , "else"
              , "enum"
              , "eval"
              , "export"
              , "extends"
              , "final"
              , "finally"
              , "float"
              , "for"
              , "function"
              , "goto"
              , "if"
              , "implements"
              , "import"
              , "in"
              , "instanceof"
              , "int"
              , "interface"
              , "let"
              , "long"
              , "native"
              , "new"
              , "null"
              , "package"
              , "private"
              , "protected"
              , "public"
              , "return"
              , "short"
              , "static"
              , "super"
              , "switch"
              , "synchronized"
              , "this"
              , "throw"
              , "throws"
              , "transient"
              , "try"
              , "typeof"
              , "var"
              , "void"
              , "volatile"
              , "while"
              , "with"
              , "yield" ]

-- |
-- Test if a string is a valid JS identifier (may return false negatives)
--
isIdent :: String -> Boolean
isIdent = test rxIdent

moduleNameToJs :: ModuleName -> String
moduleNameToJs (ModuleName pns) = joinWith "_" (runProperName `map` pns)

rxAlphaNum :: Regex
rxAlphaNum = regex "[a-z0-9]" "i"

rxIdent :: Regex
rxIdent = regex "^[a-z][a-z0-9]*$" "i"

module Language.PureScript.CodeGen.Common where

import Data.Array (concatMap, map)
import Data.Foldable (all, elem, foldMap)
import Data.Monoid ()
import Data.String (charCodeAt, joinWith, split)
import Data.String.Regex (Regex(..), regex, test)
import Language.PureScript.Names

-- |
-- Convert an Ident into a valid Javascript identifier:
--
--  * Alphanumeric characters are kept unmodified.
--
--  * Reserved javascript identifiers are prefixed with '$$'.
--
--  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
--
identToJs :: Ident -> String
identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
identToJs (Ident name) = foldMap identCharToString (split name "")
identToJs (Op op) = foldMap identCharToString (split op "")

-- |
-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
-- ordinal value.
--
identCharToString :: String -> String
identCharToString c | test rxAlphaNum c = c
identCharToString "_" = "_"
identCharToString "." = "$dot"
identCharToString "$" = "$dollar"
identCharToString "~" = "$tilde"
identCharToString "=" = "$eq"
identCharToString "<" = "$less"
identCharToString ">" = "$greater"
identCharToString "!" = "$bang"
identCharToString "#" = "$hash"
identCharToString "%" = "$percent"
identCharToString "^" = "$up"
identCharToString "&" = "$amp"
identCharToString "|" = "$bar"
identCharToString "*" = "$times"
identCharToString "/" = "$div"
identCharToString "+" = "$plus"
identCharToString "-" = "$minus"
identCharToString ":" = "$colon"
identCharToString "\\" = "$bslash"
identCharToString "?" = "$qmark"
identCharToString "@" = "$at"
identCharToString "\'" = "$prime"
identCharToString c = "$" ++ show (charCodeAt 0 c)

-- |
-- Checks whether an identifier name is reserved in Javascript.
--
nameIsJsReserved :: String -> Boolean
nameIsJsReserved name =
  name `elem` [ "abstract"
              , "arguments"
              , "boolean"
              , "break"
              , "byte"
              , "case"
              , "catch"
              , "char"
              , "class"
              , "const"
              , "continue"
              , "debugger"
              , "default"
              , "delete"
              , "do"
              , "double"
              , "else"
              , "enum"
              , "eval"
              , "export"
              , "extends"
              , "final"
              , "finally"
              , "float"
              , "for"
              , "function"
              , "goto"
              , "if"
              , "implements"
              , "import"
              , "in"
              , "instanceof"
              , "int"
              , "interface"
              , "let"
              , "long"
              , "native"
              , "new"
              , "null"
              , "package"
              , "private"
              , "protected"
              , "public"
              , "return"
              , "short"
              , "static"
              , "super"
              , "switch"
              , "synchronized"
              , "this"
              , "throw"
              , "throws"
              , "transient"
              , "try"
              , "typeof"
              , "var"
              , "void"
              , "volatile"
              , "while"
              , "with"
              , "yield" ]

-- |
-- Test if a string is a valid JS identifier (may return false negatives)
--
isIdent :: String -> Boolean
isIdent = test rxIdent

moduleNameToJs :: ModuleName -> String
moduleNameToJs (ModuleName pns) = joinWith "_" (runProperName `map` pns)

rxAlphaNum :: Regex
rxAlphaNum = regex "[a-z0-9]" "i"

rxIdent :: Regex
rxIdent = regex "^[a-z][a-z0-9]+$" "i"


Added window dimensions signal

Added window dimensions signal

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , touch
  , tap
  , mousePos
  , windowDims
  , CoordinatePair(..)
  , DimensionPair(..)
  , Touch(..)
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import DOM (DOM(..))
import Signal (constant, Signal(..), (~>), unwrap)
import Signal.Time (now, Time(..))

type CoordinatePair = { x :: Number, y :: Number }
type DimensionPair  = { w :: Number, h :: Number }

foreign import keyPressedP """
  function keyPressedP(constant, keyCode) {
    return function() {
      var out = constant(false);
      window.addEventListener("keydown", function(e) {
        if (e.keyCode === keyCode) out.set(true);
      });
      window.addEventListener("keyup", function(e) {
        if (e.keyCode === keyCode) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

keyPressed :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
keyPressed = runFn2 keyPressedP constant

foreign import mouseButtonP """
  function mouseButtonP(constant, button) {
    return function() {
      var out = constant(false);
      window.addEventListener("mousedown", function(e) {
        if (e.button === button) out.set(true);
      });
      window.addEventListener("mouseup", function(e) {
        if (e.button === button) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

mouseButton :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
mouseButton = runFn2 mouseButtonP constant

type Touch = { id :: String
             , screenX :: Number, screenY :: Number
             , clientX :: Number, clientY :: Number
             , pageX :: Number, pageY :: Number
             , radiusX :: Number, radiusY :: Number
             , rotationAngle :: Number, force :: Number }

foreign import touchP """
  function touchP(constant) {
    var out = constant(false);
    function report(e) {
      var touches = [], i, l = e.touches.length;
      for (i = 0; i < l; i++) touches.push(e.touches.item(i));
      out.set(touches);
    }
    window.addEventListener("touchstart", report);
    window.addEventListener("touchend", report);
    window.addEventListener("touchmove", report);
    window.addEventListener("touchcancel", report);
    return function() {
      return out;
    };
  }""" :: forall e c. Fn1 (c -> Signal c) (Eff (dom :: DOM | e) (Signal [Touch]))

touch :: forall e. Eff (dom :: DOM | e) (Signal [Touch])
touch = runFn1 touchP constant

tap :: forall e. Eff (dom :: DOM | e) (Signal Boolean)
tap = do
  touches <- touch
  return $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP """
  function mousePosP(constant) {
    var out = constant({x:0,y:0});
    window.addEventListener('mousemove', function(e) {
      if (e.pageX !== undefined && e.pageY !== undefined) {
        out.set({x:e.pageX, y: e.pageY});
      } else if (e.clientX !== undefined && e.clientY !== undefined) {
        out.set({
          x: e.clientX + document.body.scrollLeft +
             document.documentElement.scrollLeft,
          y: e.clientY + document.body.scrollTop +
             document.documentElement.scrollTop
        });
      } else {
        throw new Error('Mouse event has no coordinates I recognise!');
      }
    });
    return function() {
      return out;
    };
  }""" :: forall e c. (c -> Signal c) -> Eff (dom :: DOM | e) (Signal CoordinatePair)

mousePos :: forall e. Eff (dom :: DOM | e) (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import windowDimsP """
  function windowDimsP(constant) {
    var out = constant({ w: window.innerWidth, h: innerHeight });
    window.addEventListener("resize", function() {
       out.set({ w: window.innerWidth, h: window.innerHeight });
    });
    return function() {
      return out;
    }
  }""" :: forall e c. (c -> Signal c) -> Eff (dom :: DOM | e) (Signal DimensionPair)

windowDims :: forall e. Eff (dom :: DOM | e) (Signal DimensionPair)
windowDims = windowDimsP constant

foreign import animationFrameP """
  function animationFrameP(constant, now) {
    return function() {
      var requestAnimFrame, cancelAnimFrame;
      if (window.requestAnimationFrame) {
        requestAnimFrame = window.requestAnimationFrame;
        cancelAnimFrame = window.cancelAnimationFrame;
      } else if (window.mozRequestAnimationFrame) {
        requestAnimFrame = window.mozRequestAnimationFrame;
        cancelAnimFrame = window.mozCancelAnimationFrame;
      } else if (window.webkitRequestAnimationFrame) {
        requestAnimFrame = window.webkitRequestAnimationFrame;
        cancelAnimFrame = window.webkitCancelAnimationFrame;
      } else if (window.msRequestAnimationFrame) {
        requestAnimFrame = window.msRequestAnimationFrame;
        cancelAnimFrame = window.msCancelAnimationFrame;
      } else if (window.oRequestAnimationFrame) {
        requestAnimFrame = window.oRequestAnimationFrame;
        cancelAnimFrame = window.oCancelAnimationFrame;
      } else {
        requestAnimFrame = function(cb) {setTimeout(function() {cb(now())}, 1000/60)};
        cancelAnimFrame = window.clearTimeout;
      }
      var out = constant(now());
      requestAnimFrame(function tick(t) {
        out.set(t); requestAnimFrame(tick);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) (Eff (timer :: Timer | e) Time) (Eff (dom :: DOM, timer :: Timer | e) (Signal Time))

animationFrame :: forall e. Eff (dom :: DOM, timer :: Timer | e) (Signal Time)
animationFrame = runFn2 animationFrameP constant now

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , touch
  , tap
  , mousePos
  , CoordinatePair(..)
  , Touch(..)
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import DOM (DOM(..))
import Signal (constant, Signal(..), (~>), unwrap)
import Signal.Time (now, Time(..))

type CoordinatePair = { x :: Number, y :: Number }

foreign import keyPressedP """
  function keyPressedP(constant, keyCode) {
    return function() {
      var out = constant(false);
      window.addEventListener("keydown", function(e) {
        if (e.keyCode === keyCode) out.set(true);
      });
      window.addEventListener("keyup", function(e) {
        if (e.keyCode === keyCode) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

keyPressed :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
keyPressed = runFn2 keyPressedP constant

foreign import mouseButtonP """
  function mouseButtonP(constant, button) {
    return function() {
      var out = constant(false);
      window.addEventListener("mousedown", function(e) {
        if (e.button === button) out.set(true);
      });
      window.addEventListener("mouseup", function(e) {
        if (e.button === button) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

mouseButton :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
mouseButton = runFn2 mouseButtonP constant

type Touch = { id :: String
             , screenX :: Number, screenY :: Number
             , clientX :: Number, clientY :: Number
             , pageX :: Number, pageY :: Number
             , radiusX :: Number, radiusY :: Number
             , rotationAngle :: Number, force :: Number }

foreign import touchP """
  function touchP(constant) {
    var out = constant(false);
    function report(e) {
      var touches = [], i, l = e.touches.length;
      for (i = 0; i < l; i++) touches.push(e.touches.item(i));
      out.set(touches);
    }
    window.addEventListener("touchstart", report);
    window.addEventListener("touchend", report);
    window.addEventListener("touchmove", report);
    window.addEventListener("touchcancel", report);
    return function() {
      return out;
    };
  }""" :: forall e c. Fn1 (c -> Signal c) (Eff (dom :: DOM | e) (Signal [Touch]))

touch :: forall e. Eff (dom :: DOM | e) (Signal [Touch])
touch = runFn1 touchP constant

tap :: forall e. Eff (dom :: DOM | e) (Signal Boolean)
tap = do
  touches <- touch
  return $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP """
  function mousePosP(constant) {
    var out = constant({x:0,y:0});
    window.addEventListener('mousemove', function(e) {
      if (e.pageX !== undefined && e.pageY !== undefined) {
        out.set({x:e.pageX, y: e.pageY});
      } else if (e.clientX !== undefined && e.clientY !== undefined) {
        out.set({
          x: e.clientX + document.body.scrollLeft +
             document.documentElement.scrollLeft,
          y: e.clientY + document.body.scrollTop +
             document.documentElement.scrollTop
        });
      } else {
        throw new Error('Mouse event has no coordinates I recognise!');
      }
    });
    return function() {
      return out;
    };
  }""" :: forall e c. (c -> Signal c) -> Eff (dom :: DOM | e) (Signal CoordinatePair)

mousePos :: forall e. Eff (dom :: DOM | e) (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import animationFrameP """
  function animationFrameP(constant, now) {
    return function() {
      var requestAnimFrame, cancelAnimFrame;
      if (window.requestAnimationFrame) {
        requestAnimFrame = window.requestAnimationFrame;
        cancelAnimFrame = window.cancelAnimationFrame;
      } else if (window.mozRequestAnimationFrame) {
        requestAnimFrame = window.mozRequestAnimationFrame;
        cancelAnimFrame = window.mozCancelAnimationFrame;
      } else if (window.webkitRequestAnimationFrame) {
        requestAnimFrame = window.webkitRequestAnimationFrame;
        cancelAnimFrame = window.webkitCancelAnimationFrame;
      } else if (window.msRequestAnimationFrame) {
        requestAnimFrame = window.msRequestAnimationFrame;
        cancelAnimFrame = window.msCancelAnimationFrame;
      } else if (window.oRequestAnimationFrame) {
        requestAnimFrame = window.oRequestAnimationFrame;
        cancelAnimFrame = window.oCancelAnimationFrame;
      } else {
        requestAnimFrame = function(cb) {setTimeout(function() {cb(now())}, 1000/60)};
        cancelAnimFrame = window.clearTimeout;
      }
      var out = constant(now());
      requestAnimFrame(function tick(t) {
        out.set(t); requestAnimFrame(tick);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) (Eff (timer :: Timer | e) Time) (Eff (dom :: DOM, timer :: Timer | e) (Signal Time))

animationFrame :: forall e. Eff (dom :: DOM, timer :: Timer | e) (Signal Time)
animationFrame = runFn2 animationFrameP constant now


Tuning up some shim function defs

Tuning up some shim function defs

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

-- .accordion(config)
foreign import accordion
  """
  function accordion(config) {
    return function(ob) {
      return function() {
        ob.accordion(config);
      };
    };
  }
  """ :: forall eff r. { | r } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .button()
foreign import button
  """
  function button(ob) {
    return function() {
      ob.button();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .buttonset()
foreign import buttonset
  """
  function buttonset(ob) {
    return function() {
      ob.buttonset();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .change()
foreign import change
  """
  function change(ob) {
    return function() {
      ob.change();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        ob.click(function () { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        ob.each(function() { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .siblings(filterStr)
foreign import siblings
  """
  function siblings(filterStr) {
    return function(ob) {
      return function() {
        ob.siblings(filterStr);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .spinner()
foreign import spinner
  """
  function spinner(ob) {
    return function() {
      ob.spinner();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .tabs()
foreign import tabs
  """
  function tabs(ob) {
    return function() {
      ob.tabs();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .val(newVal)
foreign import val
  """
  function val(newVal) {
    return function(ob) {
      return function() {
        ob.val(newVal);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- $(this)
foreign import selectThis
  """
  function selectThis() {
    return jQuery(this);
  }
  """ :: forall eff. Eff (dom :: DOM | eff) JQuery

-- .attr(str)
foreign import attrStr
  """
  function attrStr(str) {
    return function(ob) {
      return function () {
        return ob.attr(str);
      };
    };
  }
  """ :: forall eff . String -> JQuery -> Eff (dom :: DOM | eff) String

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

-- .accordion(config)
foreign import accordion
  """
  function accordion(config) {
    return function(ob) {
      return function() {
        ob.accordion(config);
      };
    };
  }
  """ :: forall eff r. { | r } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .button()
foreign import button
  """
  function button(ob) {
    return function() {
      ob.button();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .buttonset()
foreign import buttonset
  """
  function buttonset(ob) {
    return function() {
      ob.buttonset();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .change()
foreign import change
  """
  function change(ob) {
    return function() {
      ob.change();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        ob.click(f);
      };
    };
  }
  """ :: forall eff a. (Unit -> Eff eff a) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        ob.each(f);
      };
    };
  }
  """ :: forall eff a. (Unit -> Eff eff a) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .siblings(filterStr)
foreign import siblings
  """
  function siblings(filterStr) {
    return function(ob) {
      return function() {
        ob.siblings(filterStr);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .spinner()
foreign import spinner
  """
  function spinner(ob) {
    return function() {
      ob.spinner();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .tabs()
foreign import tabs
  """
  function tabs(ob) {
    return function() {
      ob.tabs();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .val(newVal)
foreign import val
  """
  function val(newVal) {
    return function(ob) {
      return function() {
        ob.val(newVal);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- $(this)
foreign import selectThis
  """
  function selectThis() {
    return jQuery(this);
  }
  """ :: forall eff. Eff (dom :: DOM | eff) JQuery

-- .attr(str)
foreign import attrStr
  """
  function attrStr(str) {
    return function(ob) {
      return function () {
        return ob.attr(str);
      };
    };
  }
  """ :: forall eff . String -> JQuery -> Eff (dom :: DOM | eff) String


Add implementation note for scheduling

Add implementation note for scheduling


Compare args case insensitively

Compare args case insensitively

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length, fromList
                 , singleton, many, head, catMaybes, filter)
import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos as P
import Text.Parsing.Parser.String as P
import Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, maybe', isJust)
import Data.Generic
import Data.String (toLower, fromChar, fromCharArray)
import Data.Array as A
import Data.String as Str
import Data.String.Ext ((^=))

import Language.Docopt.Value hiding (parse, read)
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lexDescs)
import Language.Docopt.Parser.Lexer as L
import Language.Docopt.Value as Value

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name    :: String
, default :: Maybe Value
}

runArgument :: Argument -> {
  name    :: String
, default :: Maybe Value
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe Value
getDefaultValue (Default v) = either (const Nothing) Just (Value.parse v)
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $ "=" ++ a.name ++ case a.default of
                                    Nothing  -> ""
                                    (Just v) -> " [default: "
                                                    ++ prettyPrintValue v
                                                    ++ "]"

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { name: n, default: d })
  = n ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String -> Maybe String -> Argument
argument name default = Argument { name:    name
                                 , default: StringValue <$> default
                                 }

run :: String -> Either P.ParseError (List Desc)
run x = lexDescs x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = default
                }
            }

      where

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt

          arg <- maybe'
                  (\_ -> do P.optionMaybe (L.shoutName <|> L.angleName))
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Flag opt.flag
                          , arg:  flip argument Nothing <$> arg
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt

          arg <- maybe'
                  (\_ -> do P.optionMaybe (L.shoutName <|> L.angleName))
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Long opt.name
                          , arg:  flip argument Nothing <$> arg
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (a@(Just (Argument { name: n  })))
                              (Just (Argument { name: n' }))
                          | (n ^= n') = return a
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe String }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe String }
    lopt = L.lopt

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length, fromList
                 , singleton, many, head, catMaybes, filter)
import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos as P
import Text.Parsing.Parser.String as P
import Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, maybe', isJust)
import Data.Generic
import Data.String (toLower, fromChar, fromCharArray)
import Data.Array as A
import Data.String as Str

import Language.Docopt.Value hiding (parse, read)
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lexDescs)
import Language.Docopt.Parser.Lexer as L
import Language.Docopt.Value as Value

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name    :: String
, default :: Maybe Value
}

runArgument :: Argument -> {
  name    :: String
, default :: Maybe Value
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe Value
getDefaultValue (Default v) = either (const Nothing) Just (Value.parse v)
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $ "=" ++ a.name ++ case a.default of
                                    Nothing  -> ""
                                    (Just v) -> " [default: "
                                                    ++ prettyPrintValue v
                                                    ++ "]"

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { name: n, default: d })
  = n ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String -> Maybe String -> Argument
argument name default = Argument { name:    name
                                 , default: StringValue <$> default
                                 }

run :: String -> Either P.ParseError (List Desc)
run x = lexDescs x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = default
                }
            }

      where

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt

          arg <- maybe'
                  (\_ -> do P.optionMaybe (L.shoutName <|> L.angleName))
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Flag opt.flag
                          , arg:  flip argument Nothing <$> arg
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt

          arg <- maybe'
                  (\_ -> do P.optionMaybe (L.shoutName <|> L.angleName))
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Long opt.name
                          , arg:  flip argument Nothing <$> arg
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (Just a) (Just b) | (a == b) = return (pure a)
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe String }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe String }
    lopt = L.lopt


Fix shouting tests

Fix shouting tests

Fix shouting tests to match the README instructions & other language tracks.

old: "Whoachill out!"
new: "Whoa, chill out!"

module Test.Main where

import Prelude
import Test.Unit (suite, test)
import Test.Unit.Main (runTest)
import Test.Unit.Assert as Assert
import Bob as Bob

main = runTest do
  suite "Bob.hey" do
    test "stating something" do
      Assert.equal "Whatever." $
        Bob.hey "Tom-ay-totom-aaaah-to."

    test "shouting" do
      Assert.equal "Whoa, chill out!" $
        Bob.hey "WATCH OUT!"

    test "asking a question" do
      Assert.equal "Sure." $
        Bob.hey "Does this cryogenic chamber make me look fat?"

    test "asking a numeric question" do
      Assert.equal "Sure." $
        Bob.hey "You arewhat, like 15?"

    test "talking forcefully" do
      Assert.equal "Whatever." $
        Bob.hey "Let's go make out behind the gym!"

    test "using acronyms in regular speech" do
      Assert.equal "Whatever." $
        Bob.hey "It's OK if you don't want to go to the DMV."

    test "forceful questions" do
      Assert.equal "Whoa, chill out!" $
        Bob.hey "WHAT THE HELL WERE YOU THINKING?"

    test "shouting numbers" do
      Assert.equal "Whoa, chill out!" $
        Bob.hey "12, 3 GO!"

    test "only numbers" do
      Assert.equal "Whatever." $
        Bob.hey "12, 3"

    test "question with only numbers" do
      Assert.equal "Sure." $
        Bob.hey "4?"

    test "shouting with special characters" do
      Assert.equal "Whoa, chill out!" $
        Bob.hey "ZOMG THE %^*@#$(*^ ZOMBIES ARE COMING!!11!!1!"

    test "shouting with no exclamation mark" do
      Assert.equal "Whoa, chill out!" $
        Bob.hey "I HATE YOU"

    test "statement containing a question mark" do
      Assert.equal "Whatever." $
        Bob.hey "Ending with ? means a question."

    test "prattling on" do
      Assert.equal "Sure." $
        Bob.hey "Wait! Hang on. Are you going to be OK?"

    test "silence" do
      Assert.equal "Fine. Be that way!" $
        Bob.hey ""

    test "prolonged silence" do
      Assert.equal "Fine. Be that way!" $
        Bob.hey "       "

    test "alternate silences" do
      Assert.equal "Fine. Be that way!" $
        Bob.hey "\t  \n  \t   "

    test "on multiple line questions" do
      Assert.equal "Whatever." $
        Bob.hey "\nDoes this cryogenic chamber make me look fat?\nno"

module Test.Main where

import Prelude
import Test.Unit (suite, test)
import Test.Unit.Main (runTest)
import Test.Unit.Assert as Assert
import Bob as Bob

main = runTest do
  suite "Bob.hey" do
    test "stating something" do
      Assert.equal "Whatever." $
        Bob.hey "Tom-ay-totom-aaaah-to."

    test "shouting" do
      Assert.equal "Whoachill out!" $
        Bob.hey "WATCH OUT!"

    test "asking a question" do
      Assert.equal "Sure." $
        Bob.hey "Does this cryogenic chamber make me look fat?"

    test "asking a numeric question" do
      Assert.equal "Sure." $
        Bob.hey "You arewhat, like 15?"

    test "talking forcefully" do
      Assert.equal "Whatever." $
        Bob.hey "Let's go make out behind the gym!"

    test "using acronyms in regular speech" do
      Assert.equal "Whatever." $
        Bob.hey "It's OK if you don't want to go to the DMV."

    test "forceful questions" do
      Assert.equal "Whoachill out!" $
        Bob.hey "WHAT THE HELL WERE YOU THINKING?"

    test "shouting numbers" do
      Assert.equal "Whoachill out!" $
        Bob.hey "12, 3 GO!"

    test "only numbers" do
      Assert.equal "Whatever." $
        Bob.hey "12, 3"

    test "question with only numbers" do
      Assert.equal "Sure." $
        Bob.hey "4?"

    test "shouting with special characters" do
      Assert.equal "Whoachill out!" $
        Bob.hey "ZOMG THE %^*@#$(*^ ZOMBIES ARE COMING!!11!!1!"

    test "shouting with no exclamation mark" do
      Assert.equal "Whoachill out!" $
        Bob.hey "I HATE YOU"

    test "statement containing a question mark" do
      Assert.equal "Whatever." $
        Bob.hey "Ending with ? means a question."

    test "prattling on" do
      Assert.equal "Sure." $
        Bob.hey "Wait! Hang on. Are you going to be OK?"

    test "silence" do
      Assert.equal "Fine. Be that way!" $
        Bob.hey ""

    test "prolonged silence" do
      Assert.equal "Fine. Be that way!" $
        Bob.hey "       "

    test "alternate silences" do
      Assert.equal "Fine. Be that way!" $
        Bob.hey "\t  \n  \t   "

    test "on multiple line questions" do
      Assert.equal "Whatever." $
        Bob.hey "\nDoes this cryogenic chamber make me look fat?\nno"