Queue Ord instance

Queue Ord instance

-- | This module defines a strict queue.
-- |
-- | The queue implementation is based on a pair of lists where all
-- | operations require `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Simple and Efficient Purely Functional Queues and Dequeues](http://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf) (Okasaki 1995)
module Data.CatQueue
  ( CatQueue(..)
  , empty
  , null
  , singleton
  , length
  , append
  , snoc
  , uncons
  , fromFoldable
  ) where

import Prelude hiding (append)

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Foldable (class Foldable, foldMap, foldMapDefaultL, foldl, foldrDefault)
import Data.List (List(..), reverse)
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid)
import Data.Traversable (class Traversable, sequenceDefault)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)

-- | A strict queue representated using a pair of lists.
data CatQueue a = CatQueue (List a) (List a)

-- | Create an empty queue.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatQueue a
empty = CatQueue Nil Nil

-- | Test whether a queue is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatQueue a -> Boolean
null (CatQueue Nil Nil) = true
null _ = false

-- | Append all elements of a queue to the end of another
-- | queue, creating a new queue.
-- |
-- | Running time: `O(n) in the length of the second queue`
append :: forall a. CatQueue a -> CatQueue a -> CatQueue a
append cq = foldl snoc cq

-- | Create a queue containing a single element.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatQueue a
singleton = snoc empty

-- | Number of elements in queue.
-- |
-- | Running time: `O(n)` in length of queue.
length :: forall a. CatQueue a -> Int
length (CatQueue l r) = L.length l + L.length r

-- | Append an element to the end of the queue, creating a new queue.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatQueue a -> a -> CatQueue a
snoc (CatQueue l r) a = CatQueue l (Cons a r)

-- | Decompose a queue into a `Tuple` of the first element and the rest of the queue.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatQueue a -> Maybe (Tuple a (CatQueue a))
uncons (CatQueue Nil Nil) = Nothing
uncons (CatQueue Nil r) = uncons (CatQueue (reverse r) Nil)
uncons (CatQueue (Cons a as) r) = Just (Tuple a (CatQueue as r))

-- | Convert any `Foldable` into a `CatQueue`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f a. Foldable f => f a -> CatQueue a
fromFoldable f = foldMap singleton f

cqEq :: forall a. Eq a => CatQueue a -> CatQueue a -> Boolean
cqEq = go
  where
    elemEq = eq :: (a -> a -> Boolean)
    go xs ys = case uncons xs, uncons ys of
      Just (Tuple x xs'), Just (Tuple y ys')
        | x `elemEq` y -> go xs' ys'
      Nothing, Nothing -> true
      _      , _       -> false

cqCompare :: forall a. Ord a => CatQueue a -> CatQueue a -> Ordering
cqCompare = go
  where
    elemCompare = compare :: (a -> a -> Ordering)
    go xs ys = case uncons xs, uncons ys of
      Just (Tuple x xs'), Just (Tuple y ys') ->
        case elemCompare x y of
             EQ       -> go xs' ys'
             ordering -> ordering
      Just _,   Nothing -> GT
      Nothing,  Just _  -> LT
      Nothing,  Nothing -> EQ

instance eqCatQueue :: Eq a => Eq (CatQueue a) where
  eq = cqEq

instance ordCatQueue :: Ord a => Ord (CatQueue a) where
  compare = cqCompare

instance semigroupCatQueue :: Semigroup (CatQueue a) where
  append = append

instance monoidCatQueue :: Monoid (CatQueue a) where
  mempty = empty

instance showCatQueue :: Show a => Show (CatQueue a) where
  show (CatQueue l r) = "(CatQueue " <> show l <> " " <> show r <> ")"

instance foldableCatQueue :: Foldable CatQueue where
  foldMap f q = foldMapDefaultL f q
  foldr f s q = foldrDefault f s q
  foldl f = go
    where
    go acc q = case uncons q of
       Just (Tuple x xs) -> go (f acc x) xs
       Nothing -> acc

instance unfoldableCatQueue :: Unfoldable CatQueue where
  unfoldr f b = go b empty
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance traversableCatQueue :: Traversable CatQueue where
  traverse f =
    map (foldl snoc empty)
    <<< foldl (\acc -> lift2 snoc acc <<< f) (pure empty)
  sequence = sequenceDefault

instance functorCatQueue :: Functor CatQueue where
  map f (CatQueue l r) = CatQueue (map f l) (map f r)

instance applyCatQueue :: Apply CatQueue where
  apply = ap

instance applicativeCatQueue :: Applicative CatQueue where
  pure = singleton

instance bindCatQueue :: Bind CatQueue where
  bind = flip foldMap

instance monadCatQueue :: Monad CatQueue

instance altCatQueue :: Alt CatQueue where
  alt = append

instance plusCatQueue :: Plus CatQueue where
  empty = empty

instance alternativeCatQueue :: Alternative CatQueue

instance monadZeroCatQueue :: MonadZero CatQueue

instance monadPlusCatQueue :: MonadPlus CatQueue

-- | This module defines a strict queue.
-- |
-- | The queue implementation is based on a pair of lists where all
-- | operations require `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Simple and Efficient Purely Functional Queues and Dequeues](http://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf) (Okasaki 1995)
module Data.CatQueue
  ( CatQueue(..)
  , empty
  , null
  , singleton
  , length
  , append
  , snoc
  , uncons
  , fromFoldable
  ) where

import Prelude hiding (append)

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Foldable (class Foldable, foldMap, foldMapDefaultL, foldl, foldrDefault)
import Data.List (List(..), reverse)
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid)
import Data.Traversable (class Traversable, sequenceDefault)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)

-- | A strict queue representated using a pair of lists.
data CatQueue a = CatQueue (List a) (List a)

-- | Create an empty queue.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatQueue a
empty = CatQueue Nil Nil

-- | Test whether a queue is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatQueue a -> Boolean
null (CatQueue Nil Nil) = true
null _ = false

-- | Append all elements of a queue to the end of another
-- | queue, creating a new queue.
-- |
-- | Running time: `O(n) in the length of the second queue`
append :: forall a. CatQueue a -> CatQueue a -> CatQueue a
append cq = foldl snoc cq

-- | Create a queue containing a single element.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatQueue a
singleton = snoc empty

-- | Number of elements in queue.
-- |
-- | Running time: `O(n)` in length of queue.
length :: forall a. CatQueue a -> Int
length (CatQueue l r) = L.length l + L.length r

-- | Append an element to the end of the queue, creating a new queue.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatQueue a -> a -> CatQueue a
snoc (CatQueue l r) a = CatQueue l (Cons a r)

-- | Decompose a queue into a `Tuple` of the first element and the rest of the queue.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatQueue a -> Maybe (Tuple a (CatQueue a))
uncons (CatQueue Nil Nil) = Nothing
uncons (CatQueue Nil r) = uncons (CatQueue (reverse r) Nil)
uncons (CatQueue (Cons a as) r) = Just (Tuple a (CatQueue as r))

-- | Convert any `Foldable` into a `CatQueue`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f a. Foldable f => f a -> CatQueue a
fromFoldable f = foldMap singleton f

cqEq :: forall a. Eq a => CatQueue a -> CatQueue a -> Boolean
cqEq = go
  where
    elemEq = eq :: (a -> a -> Boolean)
    go xs ys = case uncons xs, uncons ys of
      Just (Tuple x xs'), Just (Tuple y ys')
        | x `elemEq` y -> go xs' ys'
      Nothing, Nothing -> true
      _      , _       -> false

instance eqCatQueue :: Eq a => Eq (CatQueue a) where
  eq = cqEq

instance semigroupCatQueue :: Semigroup (CatQueue a) where
  append = append

instance monoidCatQueue :: Monoid (CatQueue a) where
  mempty = empty

instance showCatQueue :: Show a => Show (CatQueue a) where
  show (CatQueue l r) = "(CatQueue " <> show l <> " " <> show r <> ")"

instance foldableCatQueue :: Foldable CatQueue where
  foldMap f q = foldMapDefaultL f q
  foldr f s q = foldrDefault f s q
  foldl f = go
    where
    go acc q = case uncons q of
       Just (Tuple x xs) -> go (f acc x) xs
       Nothing -> acc

instance unfoldableCatQueue :: Unfoldable CatQueue where
  unfoldr f b = go b empty
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance traversableCatQueue :: Traversable CatQueue where
  traverse f =
    map (foldl snoc empty)
    <<< foldl (\acc -> lift2 snoc acc <<< f) (pure empty)
  sequence = sequenceDefault

instance functorCatQueue :: Functor CatQueue where
  map f (CatQueue l r) = CatQueue (map f l) (map f r)

instance applyCatQueue :: Apply CatQueue where
  apply = ap

instance applicativeCatQueue :: Applicative CatQueue where
  pure = singleton

instance bindCatQueue :: Bind CatQueue where
  bind = flip foldMap

instance monadCatQueue :: Monad CatQueue

instance altCatQueue :: Alt CatQueue where
  alt = append

instance plusCatQueue :: Plus CatQueue where
  empty = empty

instance alternativeCatQueue :: Alternative CatQueue

instance monadZeroCatQueue :: MonadZero CatQueue

instance monadPlusCatQueue :: MonadPlus CatQueue


Add Julian year

Add Julian year

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

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)
import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (traverse_)
import Data.Foldable as F
import Data.List (List, many)
import Data.Map (lookup)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Semigroup.Foldable (foldl1, foldr1)
import Data.String (fromCodePointArray, codePointFromChar, singleton)
import Insect.Environment (Environment, StoredFunction(..))
import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..), Identifier)
import Quantities (DerivedUnit, (./))
import Quantities as Q
import Parsing (ParserT, Parser, ParseError, runParser, fail)
import Parsing.Combinators (option, optionMaybe, try, (<?>), notFollowedBy)
import Parsing.String (string, char, eof)
import Parsing.String.Basic (oneOf)
import Parsing.Token (GenLanguageDef(..), LanguageDef, TokenParser, digit, letter, makeTokenParser)

-- | 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", "copy", "cp"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , 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 reserved 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
  decimalPart ← fractionalPart <|> do
    intPart ← digits
    mFracPart ← optionMaybe fractionalPart
    pure (intPart <> fromMaybe "" mFracPart)

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

  whiteSpace

  let floatStr = decimalPart <> 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)

    fractionalPart ∷ P String
    fractionalPart = (<>) <$> string "." <*> digits

    fromCharArray = fromCodePointArray <<< map codePointFromChar

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

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure identity

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henrys","henries","henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU", "au", "astronomicalunits", "astronomicalunit"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "amps", "amp", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.julianYear ==> ["julianYears", "julianYear"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  , Q.pixel ==> ["pixels", "pixel", "px"]
  , Q.frame ==> ["frames", "frame"]
  , Q.frame ./ Q.second ==> ["fps"]
  , Q.dot ==> ["dots", "dot"]
  ]

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

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.percent ==> ["pct", "percent"]
  , Q.partsPerMillion ==> ["ppm"]
  , Q.partsPerBillion ==> ["ppb"]
  , Q.partsPerTrillion ==> ["ppt"]
  , Q.partsPerQuadrillion ==> ["ppq"]
  , Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.thou ==> ["thou", "mils", "mil"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.lbf ==> ["pound_force", "lbf"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  , Q.pixel ./ Q.inch ==> ["ppi"]
  , Q.dot ./ Q.inch ==> ["dpi"]
  , Q.piece ==> ["pieces", "piece"]
  , Q.person ==> ["persons", "person", "people"]
  , Q.dollar ==> ["dollars", "dollar", "USD", "$"]
  , Q.euro ==> ["euros", "euro", "EUR", "€"]
  , Q.knot ==> ["knots", "knot", "kn", "kt"]
  , Q.nauticalMile ==> ["M", "NM", "nmi"]
  ]

-- | 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 ← prefix
  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 Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.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

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. 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)

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  if name == "sum" || name == "product"
    then
      pure name
    else
      case lookup name env.functions of
        Just (StoredFunction _ _ _) → pure name
        Nothing → fail ("Unknown function '" <> name <> "'")

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

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

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        pure case mFn of
          Just fn → fn x
          Nothing → x

      -- The power operator needs special treatment
      -- 1) it is right-associative => use foldr1 instead of foldl1
      -- 2) the unary minus on the *left* side of the power operator has
      --    a lower precedence, i.e. -2^3 = -(2^3). However, unary minus
      --    on the *right* side has a higher precedence: 2^-3 = 2^(-3).
      sepByPow ∷ P Expression
      sepByPow = fix \e → foldr1 (BinOp Pow) <$> list e
        where
          list e = do
            a ← suffixPow
            as ← many do
              powOp
              func ← (subOp *> pure Negate) <|> (addOp *> pure identity) <|> pure identity
              expr ← e
              pure (func expr)
            pure (a :| as)

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

      prefixed ∷ P Expression
      prefixed = fix \e →
            (subOp *> (Negate <$> e))
        <|> (addOp *> e)
        <|> sepByMulImplicit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> prefixed `sepBy1` modOp

      sepByPer ∷ P Expression
      sepByPer = foldl1 (BinOp Div) <$> sepByMod `sepBy1` perOp

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

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

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> sepByMul `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

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    perOp = reserved "per"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

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

-- | 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 "copy" <|> reserved "cp") *> pure Copy
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name, args, expr }

  -- Fail if the name can be parsed as a physical unit
  failIfUnit name

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → do
      traverse_ failIfUnit xs
      pure (FunctionAssignment name xs expr)

  where
    failIfUnit n =
      when (isRight $ runParser n (derivedUnit <* eof)) $
        fail ("'" <> n <> "' is reserved for a physical unit")

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (try (whiteSpace *> (PrettyPrintFunction <$> function env) <* eof))
  <|> (Expression <$> fullExpression env)

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

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

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)
import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (traverse_)
import Data.Foldable as F
import Data.List (List, many)
import Data.Map (lookup)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Semigroup.Foldable (foldl1, foldr1)
import Data.String (fromCodePointArray, codePointFromChar, singleton)
import Insect.Environment (Environment, StoredFunction(..))
import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..), Identifier)
import Quantities (DerivedUnit, (./))
import Quantities as Q
import Parsing (ParserT, Parser, ParseError, runParser, fail)
import Parsing.Combinators (option, optionMaybe, try, (<?>), notFollowedBy)
import Parsing.String (string, char, eof)
import Parsing.String.Basic (oneOf)
import Parsing.Token (GenLanguageDef(..), LanguageDef, TokenParser, digit, letter, makeTokenParser)

-- | 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", "copy", "cp"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , 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 reserved 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
  decimalPart ← fractionalPart <|> do
    intPart ← digits
    mFracPart ← optionMaybe fractionalPart
    pure (intPart <> fromMaybe "" mFracPart)

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

  whiteSpace

  let floatStr = decimalPart <> 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)

    fractionalPart ∷ P String
    fractionalPart = (<>) <$> string "." <*> digits

    fromCharArray = fromCodePointArray <<< map codePointFromChar

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

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure identity

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henrys","henries","henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU", "au", "astronomicalunits", "astronomicalunit"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "amps", "amp", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  , Q.pixel ==> ["pixels", "pixel", "px"]
  , Q.frame ==> ["frames", "frame"]
  , Q.frame ./ Q.second ==> ["fps"]
  , Q.dot ==> ["dots", "dot"]
  ]

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

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.percent ==> ["pct", "percent"]
  , Q.partsPerMillion ==> ["ppm"]
  , Q.partsPerBillion ==> ["ppb"]
  , Q.partsPerTrillion ==> ["ppt"]
  , Q.partsPerQuadrillion ==> ["ppq"]
  , Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.thou ==> ["thou", "mils", "mil"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.lbf ==> ["pound_force", "lbf"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  , Q.pixel ./ Q.inch ==> ["ppi"]
  , Q.dot ./ Q.inch ==> ["dpi"]
  , Q.piece ==> ["pieces", "piece"]
  , Q.person ==> ["persons", "person", "people"]
  , Q.dollar ==> ["dollars", "dollar", "USD", "$"]
  , Q.euro ==> ["euros", "euro", "EUR", "€"]
  , Q.knot ==> ["knots", "knot", "kn", "kt"]
  , Q.nauticalMile ==> ["M", "NM", "nmi"]
  ]

-- | 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 ← prefix
  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 Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.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

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. 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)

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  if name == "sum" || name == "product"
    then
      pure name
    else
      case lookup name env.functions of
        Just (StoredFunction _ _ _) → pure name
        Nothing → fail ("Unknown function '" <> name <> "'")

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

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

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        pure case mFn of
          Just fn → fn x
          Nothing → x

      -- The power operator needs special treatment
      -- 1) it is right-associative => use foldr1 instead of foldl1
      -- 2) the unary minus on the *left* side of the power operator has
      --    a lower precedence, i.e. -2^3 = -(2^3). However, unary minus
      --    on the *right* side has a higher precedence: 2^-3 = 2^(-3).
      sepByPow ∷ P Expression
      sepByPow = fix \e → foldr1 (BinOp Pow) <$> list e
        where
          list e = do
            a ← suffixPow
            as ← many do
              powOp
              func ← (subOp *> pure Negate) <|> (addOp *> pure identity) <|> pure identity
              expr ← e
              pure (func expr)
            pure (a :| as)

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

      prefixed ∷ P Expression
      prefixed = fix \e →
            (subOp *> (Negate <$> e))
        <|> (addOp *> e)
        <|> sepByMulImplicit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> prefixed `sepBy1` modOp

      sepByPer ∷ P Expression
      sepByPer = foldl1 (BinOp Div) <$> sepByMod `sepBy1` perOp

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

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

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> sepByMul `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

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    perOp = reserved "per"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

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

-- | 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 "copy" <|> reserved "cp") *> pure Copy
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name, args, expr }

  -- Fail if the name can be parsed as a physical unit
  failIfUnit name

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → do
      traverse_ failIfUnit xs
      pure (FunctionAssignment name xs expr)

  where
    failIfUnit n =
      when (isRight $ runParser n (derivedUnit <* eof)) $
        fail ("'" <> n <> "' is reserved for a physical unit")

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (try (whiteSpace *> (PrettyPrintFunction <$> function env) <* eof))
  <|> (Expression <$> fullExpression env)

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


readPropImpl now checks for null and undefined of its arg.

module Data.Foreign
  ( Foreign(..)
  , ForeignParser(ForeignParser)
  , parseForeign
  , parseJSON
  , ReadForeign
  , read
  , prop
  , keys
  ) where

import Data.Array
import Data.Function
import Data.Either
import Data.Maybe
import Data.Tuple
import Data.Traversable
import Global (Error(..))

foreign import data Foreign :: *

foreign import fromStringImpl
  "function fromStringImpl(left, right, str) { \
  \  try { \
  \    return right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return left(e.toString()); \
  \  } \
  \}" :: Fn3 (String -> Either String Foreign) (Foreign -> Either String Foreign) String (Either String Foreign)

fromString :: String -> Either String Foreign
fromString = runFn3 fromStringImpl Left Right

foreign import readPrimTypeImpl
  "function readPrimTypeImpl(left, right, typeName, value) { \
  \  if (toString.call(value) == '[object ' + typeName + ']') { \
  \    return right(value);\
  \  } \
  \  return left('Value is not a ' + typeName + ''); \
  \}" :: forall a. Fn4 (String -> Either String a) (a -> Either String a) String Foreign (Either String a)

readPrimType :: forall a. String -> Foreign -> Either String a
readPrimType = runFn4 readPrimTypeImpl Left Right

foreign import readMaybeImpl
  "function readMaybeImpl(nothing, just, value) { \
  \  return value === undefined || value === null ? nothing : just(value); \
  \}" :: forall a. Fn3 (Maybe Foreign) (Foreign -> Maybe Foreign) Foreign (Maybe Foreign)

readMaybeImpl' :: Foreign -> Maybe Foreign
readMaybeImpl' = runFn3 readMaybeImpl Nothing Just

-- We use == to check for both null and undefined
foreign import readPropImpl
  "function readPropImpl(k, obj) { \
  \    return obj == undefined ? undefined : obj[k];\
  \}" :: forall a. Fn2 String Foreign Foreign

readPropImpl' :: String -> Foreign -> Foreign
readPropImpl' = runFn2 readPropImpl

-- We use == to check for both null and undefined
foreign import readKeysImpl
  "function readKeysImpl(left, right, k, obj) { \
  \  if (obj == undefined) { \
  \    return left('cannot get a key from an undefined or null value'); \
  \  } else if (obj[k] == undefined) { \
  \    return left('value is undefined or null'); \
  \  } else if (Array.isArray(obj[k])) { \
  \    return left('value is an array'); \
  \  } else if (typeof obj[k] !== 'object') { \
  \    return left('value is not an object'); \
  \  } \
  \  return right(Object.keys(obj[k])); \
  \}"
  :: forall a. Fn4 (String -> Either String a) (a -> Either String a) String Foreign (Either String [String])

readKeysImpl' :: String -> Foreign -> Either String [String]
readKeysImpl' = runFn4 readKeysImpl Left Right

foreign import showForeignImpl
  "var showForeignImpl = JSON.stringify;" :: Foreign -> String

instance showForeign :: Prelude.Show Foreign where
  show = showForeignImpl

data ForeignParser a = ForeignParser (Foreign -> Either String a)

parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
parseForeign (ForeignParser p) x = p x

parseJSON :: forall a. (ReadForeign a) => String -> Either String a
parseJSON json = fromString json >>= parseForeign read

instance functorForeignParser :: Prelude.Functor ForeignParser where
  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x

instance bindForeignParser :: Prelude.Bind ForeignParser where
  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
      Left err -> Left err
      Right x' -> parseForeign (f x') x

instance applyForeignParser :: Prelude.Apply ForeignParser where
  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
  pure x = ForeignParser \_ -> Right x

instance monadForeignParser :: Prelude.Monad ForeignParser

class ReadForeign a where
  read :: ForeignParser a

instance readString :: ReadForeign String where
  read = ForeignParser $ readPrimType "String"

instance readNumber :: ReadForeign Number where
  read = ForeignParser $ readPrimType "Number"

instance readBoolean :: ReadForeign Boolean where
  read = ForeignParser $ readPrimType "Boolean"

instance readError :: ReadForeign Error where
  read = ForeignParser $ readPrimType "Error"

instance readArray :: (ReadForeign a) => ReadForeign [a] where
  read = let
    arrayItem (Tuple i x) = case parseForeign read x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (ForeignParser $ readPrimType "Array") >>= \xs ->
      ForeignParser \_ -> arrayItem `traverse` (zip (range 0 (length xs)) xs)

instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
  read = (ForeignParser $ Right <<< readMaybeImpl') >>= \x ->
    ForeignParser \_ -> case x of
      Just x' -> parseForeign read x' >>= return <<< Just
      Nothing -> return Nothing

prop :: forall a. (ReadForeign a) => String -> ForeignParser a
prop p = (ForeignParser \x -> Right $ readPropImpl' p x) >>= \x ->
  ForeignParser \_ -> case parseForeign read x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

keys :: String -> ForeignParser [String]
keys p = ForeignParser \x -> case readKeysImpl' p x of
  Right result -> Right result
  Left err -> Left $ "Error reading object keys of '" ++ p ++ "':\n" ++ err

module Data.Foreign
  ( Foreign(..)
  , ForeignParser(ForeignParser)
  , parseForeign
  , parseJSON
  , ReadForeign
  , read
  , prop
  , keys
  ) where

import Data.Array
import Data.Function
import Data.Either
import Data.Maybe
import Data.Tuple
import Data.Traversable
import Global (Error(..))

foreign import data Foreign :: *

foreign import fromStringImpl
  "function fromStringImpl(left, right, str) { \
  \  try { \
  \    return right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return left(e.toString()); \
  \  } \
  \}" :: Fn3 (String -> Either String Foreign) (Foreign -> Either String Foreign) String (Either String Foreign)

fromString :: String -> Either String Foreign
fromString = runFn3 fromStringImpl Left Right

foreign import readPrimTypeImpl
  "function readPrimTypeImpl(left, right, typeName, value) { \
  \  if (toString.call(value) == '[object ' + typeName + ']') { \
  \    return right(value);\
  \  } \
  \  return left('Value is not a ' + typeName + ''); \
  \}" :: forall a. Fn4 (String -> Either String a) (a -> Either String a) String Foreign (Either String a)

readPrimType :: forall a. String -> Foreign -> Either String a
readPrimType = runFn4 readPrimTypeImpl Left Right

foreign import readMaybeImpl
  "function readMaybeImpl(nothing, just, value) { \
  \  return value === undefined || value === null ? nothing : just(value); \
  \}" :: forall a. Fn3 (Maybe Foreign) (Foreign -> Maybe Foreign) Foreign (Maybe Foreign)

readMaybeImpl' :: Foreign -> Maybe Foreign
readMaybeImpl' = runFn3 readMaybeImpl Nothing Just

foreign import readPropImpl
  "function readPropImpl(k, obj) { \
  \    return obj === undefined ? undefined : obj[k];\
  \}" :: forall a. Fn2 String Foreign Foreign

readPropImpl' :: String -> Foreign -> Foreign
readPropImpl' = runFn2 readPropImpl

-- We use == to check for both null and undefined
foreign import readKeysImpl
  "function readKeysImpl(left, right, k, obj) { \
  \  if (obj == undefined) { \
  \    return left('cannot get a key from an undefined or null value'); \
  \  } else if (obj[k] == undefined) { \
  \    return left('value is undefined or null'); \
  \  } else if (Array.isArray(obj[k])) { \
  \    return left('value is an array'); \
  \  } else if (typeof obj[k] !== 'object') { \
  \    return left('value is not an object'); \
  \  } \
  \  return right(Object.keys(obj[k])); \
  \}"
  :: forall a. Fn4 (String -> Either String a) (a -> Either String a) String Foreign (Either String [String])

readKeysImpl' :: String -> Foreign -> Either String [String]
readKeysImpl' = runFn4 readKeysImpl Left Right

foreign import showForeignImpl
  "var showForeignImpl = JSON.stringify;" :: Foreign -> String

instance showForeign :: Prelude.Show Foreign where
  show = showForeignImpl

data ForeignParser a = ForeignParser (Foreign -> Either String a)

parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
parseForeign (ForeignParser p) x = p x

parseJSON :: forall a. (ReadForeign a) => String -> Either String a
parseJSON json = fromString json >>= parseForeign read

instance functorForeignParser :: Prelude.Functor ForeignParser where
  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x

instance bindForeignParser :: Prelude.Bind ForeignParser where
  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
      Left err -> Left err
      Right x' -> parseForeign (f x') x

instance applyForeignParser :: Prelude.Apply ForeignParser where
  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
  pure x = ForeignParser \_ -> Right x

instance monadForeignParser :: Prelude.Monad ForeignParser

class ReadForeign a where
  read :: ForeignParser a

instance readString :: ReadForeign String where
  read = ForeignParser $ readPrimType "String"

instance readNumber :: ReadForeign Number where
  read = ForeignParser $ readPrimType "Number"

instance readBoolean :: ReadForeign Boolean where
  read = ForeignParser $ readPrimType "Boolean"

instance readError :: ReadForeign Error where
  read = ForeignParser $ readPrimType "Error"

instance readArray :: (ReadForeign a) => ReadForeign [a] where
  read = let
    arrayItem (Tuple i x) = case parseForeign read x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (ForeignParser $ readPrimType "Array") >>= \xs ->
      ForeignParser \_ -> arrayItem `traverse` (zip (range 0 (length xs)) xs)

instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
  read = (ForeignParser $ Right <<< readMaybeImpl') >>= \x ->
    ForeignParser \_ -> case x of
      Just x' -> parseForeign read x' >>= return <<< Just
      Nothing -> return Nothing

prop :: forall a. (ReadForeign a) => String -> ForeignParser a
prop p = (ForeignParser \x -> Right $ readPropImpl' p x) >>= \x ->
  ForeignParser \_ -> case parseForeign read x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

keys :: String -> ForeignParser [String]
keys p = ForeignParser \x -> case readKeysImpl' p x of
  Right result -> Right result
  Left err -> Left $ "Error reading object keys of '" ++ p ++ "':\n" ++ err


Further clarification

Further clarification

module Data.Date
  ( Date
  , canonicalDate
  , exactDate
  , year
  , month
  , day
  , weekday
  , diff
  , isLeapYear
  , lastDayOfMonth
  , adjust
  , module Data.Date.Component
  ) where

import Prelude

import Data.Date.Component (Day, Month(..), Weekday(..), Year)
import Data.Enum (class Enum, toEnum, fromEnum, succ, pred)
import Data.Function.Uncurried (Fn3, runFn3, Fn4, runFn4, Fn6, runFn6)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Milliseconds, toDuration)
import Partial.Unsafe (unsafePartial)

-- | A date value in the Gregorian calendar.
data Date = Date Year Month Day

-- | Constructs a date from year, month, and day components. The resulting date
-- | components may not be identical to the input values, as the date will be
-- | canonicalised according to the Gregorian calendar. For example, date
-- | values for the invalid date 2016-02-31 will be corrected to 2016-03-02.
canonicalDate :: Year -> Month -> Day -> Date
canonicalDate y m d = runFn4 canonicalDateImpl mkDate y (fromEnum m) d
  where
  mkDate :: Year -> Int -> Day -> Date
  mkDate = unsafePartial \y' m' d' -> Date y' (fromJust (toEnum m')) d'

-- | Constructs a date from year, month, and day components. The result will be
-- | `Nothing` if the provided values result in an invalid date.
exactDate :: Year -> Month -> Day -> Maybe Date
exactDate y m d =
  let dt = Date y m d
  in if canonicalDate y m d == dt then Just dt else Nothing

derive instance eqDate :: Eq Date
derive instance ordDate :: Ord Date

instance boundedDate :: Bounded Date where
  bottom = Date bottom bottom bottom
  top = Date top top top

instance showDate :: Show Date where
  show (Date y m d) = "(Date " <> show y <> " " <> show m <> " " <> show d <> ")"

instance enumDate :: Enum Date where
  succ (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing sd then toEnum 1 else sd
      m' = if isNothing sd then fromMaybe January sm else m
      y' = if isNothing sd && isNothing sm then succ y else Just y
      sd = let v = succ d in if v > Just l then Nothing else v
      sm = succ m
      l = lastDayOfMonth y m
  pred (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing pd then Just l else pd
      m' = if isNothing pd then fromMaybe December pm else m
      y' = if isNothing pd && isNothing pm then pred y else Just y
      pd = pred d
      pm = pred m
      l = lastDayOfMonth y m'

-- | The year component of a date value.
year :: Date -> Year
year (Date y _ _) = y

-- | The month component of a date value.
month :: Date -> Month
month (Date _ m _) = m

-- | The day component of a date value.
day :: Date -> Day
day (Date _ _ d) = d

-- | The weekday for a date value.
weekday :: Date -> Weekday
weekday = unsafePartial \(Date y m d) ->
  let n = runFn3 calcWeekday y (fromEnum m) d
  in if n == 0 then fromJust (toEnum 7) else fromJust (toEnum n)

-- | Adjusts a date with a Duration in days. The number of days must
-- | already be an integer and fall within the valid range of values
-- | for the Int type.
adjust :: Days -> Date -> Maybe Date
adjust (Days n) date = fromNumber n >>= flip adj date
  where
    adj 0 dt           = Just dt
    adj i (Date y m d) = adj i' =<< dt'
      where
        i'  | low       = j
            | hi        = j - fromEnum l - 1
            | otherwise = 0
        dt' | low       = pred =<< Date y m <$> toEnum 1
            | hi        = succ (Date y m l)
            | otherwise = Date y m <$> toEnum j
        j   = i + fromEnum d
        low = j < 1
        hi  = j > fromEnum l
        l   = lastDayOfMonth y (if low then fromMaybe December (pred m) else m)

-- | Calculates the difference between two dates, returning the result as a
-- | duration.
diff :: forall d. Duration d => Date -> Date -> d
diff (Date y1 m1 d1) (Date y2 m2 d2) =
  toDuration $ runFn6 calcDiff y1 (fromEnum m1) d1 y2 (fromEnum m2) d2

-- | Checks whether a year is a leap year according to the proleptic Gregorian
-- | calendar.
isLeapYear :: Year -> Boolean
isLeapYear y = (mod y' 4 == 0) && ((mod y' 400 == 0) || not (mod y' 100 == 0))
  where
  y' = fromEnum y

-- | Get the final day of a month and year, accounting for leap years.
lastDayOfMonth :: Year -> Month -> Day
lastDayOfMonth y m = case m of
  January -> unsafeDay 31
  February
    | isLeapYear y -> unsafeDay 29
    | otherwise -> unsafeDay 28
  March -> unsafeDay 31
  April -> unsafeDay 30
  May -> unsafeDay 31
  June -> unsafeDay 30
  July -> unsafeDay 31
  August -> unsafeDay 31
  September -> unsafeDay 30
  October -> unsafeDay 31
  November -> unsafeDay 30
  December -> unsafeDay 31
  where
    unsafeDay = unsafePartial fromJust <<< toEnum

-- TODO: these could (and probably should) be implemented in PS
foreign import canonicalDateImpl :: Fn4 (Year -> Int -> Day -> Date) Year Int Day Date
foreign import calcWeekday :: Fn3 Year Int Day Int
foreign import calcDiff :: Fn6 Year Int Day Year Int Day Milliseconds

module Data.Date
  ( Date
  , canonicalDate
  , exactDate
  , year
  , month
  , day
  , weekday
  , diff
  , isLeapYear
  , lastDayOfMonth
  , adjust
  , module Data.Date.Component
  ) where

import Prelude

import Data.Date.Component (Day, Month(..), Weekday(..), Year)
import Data.Enum (class Enum, toEnum, fromEnum, succ, pred)
import Data.Function.Uncurried (Fn3, runFn3, Fn4, runFn4, Fn6, runFn6)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Milliseconds, toDuration)
import Partial.Unsafe (unsafePartial)

-- | A date value in the Gregorian calendar.
data Date = Date Year Month Day

-- | Constructs a date from year, month, and day components. The resulting date
-- | components may not be identical to the input values, as the date will be
-- | canonicalised according to the Gregorian calendar. For example, date
-- | values for the invalid date 2016-02-31 will be corrected to 2016-03-02.
canonicalDate :: Year -> Month -> Day -> Date
canonicalDate y m d = runFn4 canonicalDateImpl mkDate y (fromEnum m) d
  where
  mkDate :: Year -> Int -> Day -> Date
  mkDate = unsafePartial \y' m' d' -> Date y' (fromJust (toEnum m')) d'

-- | Constructs a date from year, month, and day components. The result will be
-- | `Nothing` if the provided values result in an invalid date.
exactDate :: Year -> Month -> Day -> Maybe Date
exactDate y m d =
  let dt = Date y m d
  in if canonicalDate y m d == dt then Just dt else Nothing

derive instance eqDate :: Eq Date
derive instance ordDate :: Ord Date

instance boundedDate :: Bounded Date where
  bottom = Date bottom bottom bottom
  top = Date top top top

instance showDate :: Show Date where
  show (Date y m d) = "(Date " <> show y <> " " <> show m <> " " <> show d <> ")"

instance enumDate :: Enum Date where
  succ (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing sd then toEnum 1 else sd
      m' = if isNothing sd then fromMaybe January sm else m
      y' = if isNothing sd && isNothing sm then succ y else Just y
      sd = let v = succ d in if v > Just l then Nothing else v
      sm = succ m
      l = lastDayOfMonth y m
  pred (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing pd then Just l else pd
      m' = if isNothing pd then fromMaybe December pm else m
      y' = if isNothing pd && isNothing pm then pred y else Just y
      pd = pred d
      pm = pred m
      l = lastDayOfMonth y m'

-- | The year component of a date value.
year :: Date -> Year
year (Date y _ _) = y

-- | The month component of a date value.
month :: Date -> Month
month (Date _ m _) = m

-- | The day component of a date value.
day :: Date -> Day
day (Date _ _ d) = d

-- | The weekday for a date value.
weekday :: Date -> Weekday
weekday = unsafePartial \(Date y m d) ->
  let n = runFn3 calcWeekday y (fromEnum m) d
  in if n == 0 then fromJust (toEnum 7) else fromJust (toEnum n)

-- | Adjusts a date with a Duration in days. The number of days must
-- | fall within the valid range for an `Int` type otherwise `Nothing`
-- | is returned.
adjust :: Days -> Date -> Maybe Date
adjust (Days n) date = fromNumber n >>= flip adj date
  where
    adj 0 dt           = Just dt
    adj i (Date y m d) = adj i' =<< dt'
      where
        i'  | low       = j
            | hi        = j - fromEnum l - 1
            | otherwise = 0
        dt' | low       = pred =<< Date y m <$> toEnum 1
            | hi        = succ (Date y m l)
            | otherwise = Date y m <$> toEnum j
        j   = i + fromEnum d
        low = j < 1
        hi  = j > fromEnum l
        l   = lastDayOfMonth y (if low then fromMaybe December (pred m) else m)

-- | Calculates the difference between two dates, returning the result as a
-- | duration.
diff :: forall d. Duration d => Date -> Date -> d
diff (Date y1 m1 d1) (Date y2 m2 d2) =
  toDuration $ runFn6 calcDiff y1 (fromEnum m1) d1 y2 (fromEnum m2) d2

-- | Checks whether a year is a leap year according to the proleptic Gregorian
-- | calendar.
isLeapYear :: Year -> Boolean
isLeapYear y = (mod y' 4 == 0) && ((mod y' 400 == 0) || not (mod y' 100 == 0))
  where
  y' = fromEnum y

-- | Get the final day of a month and year, accounting for leap years.
lastDayOfMonth :: Year -> Month -> Day
lastDayOfMonth y m = case m of
  January -> unsafeDay 31
  February
    | isLeapYear y -> unsafeDay 29
    | otherwise -> unsafeDay 28
  March -> unsafeDay 31
  April -> unsafeDay 30
  May -> unsafeDay 31
  June -> unsafeDay 30
  July -> unsafeDay 31
  August -> unsafeDay 31
  September -> unsafeDay 30
  October -> unsafeDay 31
  November -> unsafeDay 30
  December -> unsafeDay 31
  where
    unsafeDay = unsafePartial fromJust <<< toEnum

-- TODO: these could (and probably should) be implemented in PS
foreign import canonicalDateImpl :: Fn4 (Year -> Int -> Day -> Date) Year Int Day Date
foreign import calcWeekday :: Fn3 Year Int Day Int
foreign import calcDiff :: Fn6 Year Int Day Year Int Day Milliseconds


Hide readJSONArrayItem

Hide readJSONArrayItem

module Data.JSON
  ( JSON(..)
  , JSONParser(JSONParser)
  , ReadJSON
  , runParser
  , readJSON
  , readJSONProp
  , parseJSON
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad

foreign import data JSON :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String JSON

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> JSON -> Either String a

foreign import readMaybe
  "function readMaybe (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. JSON -> Maybe JSON

foreign import readProp
  "function readProp (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> JSON -> Either String JSON

foreign import showJSONImpl
  "function showJSONImpl (obj) { \
  \  return JSON.stringify(obj); \
  \}" :: JSON -> String

instance showJSON :: Prelude.Show JSON where
  show = showJSONImpl

data JSONParser a = JSONParser (JSON -> Either String a)

runParser :: forall a. JSONParser a -> JSON -> Either String a
runParser (JSONParser p) x = p x

instance monadJSONParser :: Prelude.Monad JSONParser where
  return x = JSONParser \_ -> Right x
  (>>=) (JSONParser p) f = JSONParser \x -> case p x of
      Left err -> Left err
      Right x' -> runParser (f x') x

instance applicativeJSONParser :: Prelude.Applicative JSONParser where
  pure x = JSONParser \_ -> Right x
  (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorJSONParser :: Prelude.Functor JSONParser where
  (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

class ReadJSON a where
  readJSON :: JSONParser a

instance readJSONString :: ReadJSON String where
  readJSON = JSONParser $ readPrimType "String"

instance readJSONNumber :: ReadJSON Number where
  readJSON = JSONParser $ readPrimType "Number"

instance readJSONBoolean :: ReadJSON Boolean where
  readJSON = JSONParser $ readPrimType "Boolean"

instance readJSONArray :: (ReadJSON a) => ReadJSON [a] where
  readJSON = (JSONParser $ readPrimType "Array") >>= \xs -> JSONParser \_ ->
    readJSONArrayItem `mapM` (zip (range 0 (length xs)) xs)

readJSONArrayItem :: forall a. (ReadJSON a) => Tuple Number JSON -> Either String a
readJSONArrayItem (Tuple i x) = case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err

instance readJSONMaybe :: (ReadJSON a) => ReadJSON (Maybe a) where
  readJSON = (JSONParser $ Right <<< readMaybe) >>= \x -> JSONParser \_ ->
    case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
readJSONProp p = (JSONParser \x -> readProp p x) >>= \x -> JSONParser \_ ->
  case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

parseJSON :: forall a. (ReadJSON a) => String -> Either String a
parseJSON json = fromString json >>= runParser readJSON

module Data.JSON
  ( JSON(..)
  , JSONParser(JSONParser)
  , ReadJSON
  , runParser
  , readJSON
  , readJSONArrayItem
  , readJSONProp
  , parseJSON
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad

foreign import data JSON :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String JSON

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> JSON -> Either String a

foreign import readMaybe
  "function readMaybe (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. JSON -> Maybe JSON

foreign import readProp
  "function readProp (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> JSON -> Either String JSON

foreign import showJSONImpl
  "function showJSONImpl (obj) { \
  \  return JSON.stringify(obj); \
  \}" :: JSON -> String

instance showJSON :: Prelude.Show JSON where
  show = showJSONImpl

data JSONParser a = JSONParser (JSON -> Either String a)

runParser :: forall a. JSONParser a -> JSON -> Either String a
runParser (JSONParser p) x = p x

instance monadJSONParser :: Prelude.Monad JSONParser where
  return x = JSONParser \_ -> Right x
  (>>=) (JSONParser p) f = JSONParser \x -> case p x of
      Left err -> Left err
      Right x' -> runParser (f x') x

instance applicativeJSONParser :: Prelude.Applicative JSONParser where
  pure x = JSONParser \_ -> Right x
  (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorJSONParser :: Prelude.Functor JSONParser where
  (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

class ReadJSON a where
  readJSON :: JSONParser a

instance readJSONString :: ReadJSON String where
  readJSON = JSONParser $ readPrimType "String"

instance readJSONNumber :: ReadJSON Number where
  readJSON = JSONParser $ readPrimType "Number"

instance readJSONBoolean :: ReadJSON Boolean where
  readJSON = JSONParser $ readPrimType "Boolean"

instance readJSONArray :: (ReadJSON a) => ReadJSON [a] where
  readJSON = (JSONParser $ readPrimType "Array") >>= \xs -> JSONParser \_ ->
    readJSONArrayItem `mapM` (zip (range 0 (length xs)) xs)

readJSONArrayItem :: forall a. (ReadJSON a) => Tuple Number JSON -> Either String a
readJSONArrayItem (Tuple i x) = case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err

instance readJSONMaybe :: (ReadJSON a) => ReadJSON (Maybe a) where
  readJSON = (JSONParser $ Right <<< readMaybe) >>= \x -> JSONParser \_ ->
    case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
readJSONProp p = (JSONParser \x -> readProp p x) >>= \x -> JSONParser \_ ->
  case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

parseJSON :: forall a. (ReadJSON a) => String -> Either String a
parseJSON json = fromString json >>= runParser readJSON


Always show errors

Always show errors

module Psa.Output
  ( output
  , Output
  , OutputStats
  , trimPosition
  , trimMessage
  ) where

import Prelude
import Data.Foldable (foldl, any)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Data.Set as Set
import Data.String as Str
import Data.StrMap as StrMap
import Data.Array as Array
import Node.Path as Path
import Psa.Types (PsaOptions, PsaError, PsaAnnotedError, PsaPath(..), PsaResult, Position, Filename, Lines,
                  compareByLocation)

data ErrorTag = Error | Warning

type Output =
  { warnings :: Array PsaAnnotedError
  , errors :: Array PsaAnnotedError
  , stats :: OutputStats
  }

-- | Statistics are a ratio of errors shown to errors in total.
type OutputStats =
  { allWarnings :: StrMap.StrMap (Tuple Int Int)
  , allErrors   :: StrMap.StrMap (Tuple Int Int)
  , srcWarnings :: StrMap.StrMap (Tuple Int Int)
  , srcErrors   :: StrMap.StrMap (Tuple Int Int)
  , libWarnings :: StrMap.StrMap (Tuple Int Int)
  , libErrors   :: StrMap.StrMap (Tuple Int Int)
  }

initialStats :: OutputStats
initialStats =
  { allWarnings: StrMap.empty
  , allErrors:   StrMap.empty
  , srcWarnings: StrMap.empty
  , srcErrors:   StrMap.empty
  , libWarnings: StrMap.empty
  , libErrors:   StrMap.empty
  }

-- | Annotates a error/warning result set with original source lines, better
-- | positions, and semantic paths (lib vs src). The callback should load the
-- | requested set of lines from the absolute filename based on the tentative
-- | position information.
output
  :: forall m
   . (Monad m)
  => (Filename -> Position -> m (Maybe Lines))
  -> PsaOptions
  -> PsaResult
  -> m Output
output loadLines options result = do
  state  <- Array.foldM (onError Warning) initialState result'.warnings
  state' <- Array.foldM (onError Error) state result'.errors
  pure state'
    { warnings = Array.sortBy compareByLocation state'.warnings
    , errors = Array.sortBy compareByLocation state'.errors
    }

  where
  initialState =
    { warnings: []
    , errors: []
    , stats: initialStats
    }

  result' =
    if not options.strict
      then { warnings, errors }
      else
        let split = partition (isSrc <<< fst) warnings
         in { warnings: split.fail, errors: errors <> split.pass }
    where
      warnings = pathOf <$> result.warnings
      errors = pathOf <$> result.errors

  pathOf :: PsaError -> Tuple PsaPath PsaError
  pathOf x =
    case x.filename of
      Just f  -> Tuple (errorPath options.libDirs f (Path.relative options.cwd f)) x
      Nothing -> Tuple Unknown x

  onError :: ErrorTag -> Output -> Tuple PsaPath PsaError -> m Output
  onError tag state (Tuple path error) =
    if shouldShowError options tag path error.errorCode
      then do
        source <- fromMaybe (pure Nothing) (loadLines <$> error.filename <*> error.position)
        let position = trimPosition <$> source <*> error.position
            source' = (\p -> Array.take (p.endLine - p.startLine + 1)) <$> position <*> source
        update [{ error: error { message = trimMessage error.message }, path, position, source: source' }]
      else
        update []

    where
    update :: Array PsaAnnotedError -> m Output
    update log =
      pure $ onTag
        (_ { stats = stats, errors = state.errors <> log })
        (_ { stats = stats, warnings = state.warnings <> log })
        tag state
      where
      stats = updateStats tag path error.errorCode (not (Array.null log)) state.stats

partition :: forall a. (a -> Boolean) -> Array a -> { pass :: Array a, fail :: Array a }
partition f = foldl go { pass: [], fail: [] }
  where
  go { pass, fail } x =
    if f x
      then { pass: Array.snoc pass x, fail }
      else { pass, fail: Array.snoc fail x }

updateStats
  :: ErrorTag
  -> PsaPath
  -> String
  -> Boolean -- If the error was printed
  -> OutputStats
  -> OutputStats
updateStats tag path code printed s =
  { allWarnings: onTag id bumpCode tag s.allWarnings
  , allErrors:   onTag bumpCode id tag s.allErrors
  , srcWarnings: onTag id (onPath bumpCode id path) tag s.srcWarnings
  , srcErrors:   onTag (onPath bumpCode id path) id tag s.srcErrors
  , libWarnings: onTag id (onPath id bumpCode path) tag s.libWarnings
  , libErrors:   onTag (onPath id bumpCode path) id tag s.libErrors
  }

  where
  bumpCode = StrMap.alter alterStat code
  bump (Tuple a b) = Tuple (if printed then a + 1 else a) (b + 1)
  alterStat Nothing  = Just (bump (Tuple 0 0))
  alterStat (Just x) = Just (bump x)

shouldShowError :: PsaOptions -> ErrorTag -> PsaPath -> String -> Boolean
shouldShowError _ Error _ _ = true
shouldShowError { filterCodes, censorCodes, censorSrc, censorLib, censorWarnings } _ path code =
  not censorWarnings
  && not (censorSrc && isSrc path || censorLib && isLib path)
  && (Set.isEmpty filterCodes || Set.member code filterCodes)
  && (Set.isEmpty censorCodes || not (Set.member code censorCodes))

errorPath :: Array String -> String -> String -> PsaPath
errorPath libDirs path short =
  if any (path `startsWith` _) libDirs
    then Lib short
    else Src short
  where
  startsWith s' s =
    case Str.indexOf s s' of
      Just 0 -> true
      _      -> false

onTag :: forall a b. (a -> b) -> (a -> b) -> ErrorTag -> a -> b
onTag f g Error   x = f x
onTag f g Warning x = g x

onPath :: forall a. (a -> a) -> (a -> a) -> PsaPath -> a -> a
onPath f g (Src _) x = f x
onPath f g (Lib _) x = g x
onPath f g _       x = x

isLib :: PsaPath -> Boolean
isLib (Lib _) = true
isLib _       = false

isSrc :: PsaPath -> Boolean
isSrc (Src _) = true
isSrc _       = false

isWarning :: ErrorTag -> Boolean
isWarning Warning = true
isWarning _       = false

-- | Finds the true bounds of the source. The PureScript compiler is greedy
-- | when it comes to matching whitespace at the end of an expression, so the
-- | original source bounds always includes whitespace and comments.
trimPosition :: Lines -> Position -> Position
trimPosition lines pos =
  case lines of
    [] ->
      { startLine: pos.startLine
      , startColumn: pos.startColumn
      , endLine: pos.startLine
      , endColumn: pos.startColumn
      }

    [l] ->
      case trimCol (pos.endColumn) l of
        Just col -> pos { endLine = pos.startLine, endColumn = col }
        Nothing  -> pos { endLine = pos.startLine, endColumn = pos.startColumn }

    _ ->
      case trimPos { row: pos.endLine, col: pos.endColumn } of
        Just { row, col } -> pos { endLine = row, endColumn = col }
        Nothing           -> trimPosition [] pos

  where
  -- WARNING: here be off-by-one dragons!

  trimPos { row, col }
    | col <= 1 =
      case Array.index lines (row - pos.startLine - 1) of
        Just l -> trimPos { row: row - 1, col: Str.length l + 1 }
        _      -> Nothing

    | otherwise =
      case Array.index lines (row - pos.startLine) of
        Just l ->
          case trimCol col l of
            Just col' -> Just { row, col: col' }
            Nothing   -> trimPos { row, col: 1 }

        _      -> Nothing

  trimCol col l =
    case Str.charAt (col - 2) l of
      Just x | isPunc x -> trimCol (col - 1) l
      Just _            -> trimComment col l
      _                 -> Nothing

  -- TODO: this breaks if "--" is inside a quoted string.
  -- TODO: Block comments?
  trimComment col l =
    case Str.indexOf "--" l of
      Just x | x == 0        -> Nothing
      Just x | x < (col - 1) -> trimCol (x + 1) l
      _                      -> Just col

  isPunc ' ' = true
  isPunc ',' = true
  isPunc _   = false

-- | Trims extraneous whitespace from psc error messages.
trimMessage :: String -> String
trimMessage =
  Str.split "\n"
  >>> foldl dedent { lines: [], indent: top }
  >>> _.lines
  >>> foldl collapse []
  >>> Str.joinWith "\n"
  >>> Str.trim

  where
  dedent { lines, indent } l
    | l == ""   = { lines: Array.snoc lines l, indent }
    | otherwise =
      let indent' = Str.length $ Str.takeWhile (_ == ' ') l in
      if indent' < indent
        then { lines: Array.snoc lines (Str.drop indent' l), indent: indent' }
        else { lines: Array.snoc lines (Str.drop indent l), indent }

  collapse lines l =
    case Array.last lines of
      Just "" | l == "" -> lines
      _                 -> Array.snoc lines l

module Psa.Output
  ( output
  , Output
  , OutputStats
  , trimPosition
  , trimMessage
  ) where

import Prelude
import Data.Foldable (foldl, any)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Data.Set as Set
import Data.String as Str
import Data.StrMap as StrMap
import Data.Array as Array
import Node.Path as Path
import Psa.Types (PsaOptions, PsaError, PsaAnnotedError, PsaPath(..), PsaResult, Position, Filename, Lines,
                  compareByLocation)

data ErrorTag = Error | Warning

type Output =
  { warnings :: Array PsaAnnotedError
  , errors :: Array PsaAnnotedError
  , stats :: OutputStats
  }

-- | Statistics are a ratio of errors shown to errors in total.
type OutputStats =
  { allWarnings :: StrMap.StrMap (Tuple Int Int)
  , allErrors   :: StrMap.StrMap (Tuple Int Int)
  , srcWarnings :: StrMap.StrMap (Tuple Int Int)
  , srcErrors   :: StrMap.StrMap (Tuple Int Int)
  , libWarnings :: StrMap.StrMap (Tuple Int Int)
  , libErrors   :: StrMap.StrMap (Tuple Int Int)
  }

initialStats :: OutputStats
initialStats =
  { allWarnings: StrMap.empty
  , allErrors:   StrMap.empty
  , srcWarnings: StrMap.empty
  , srcErrors:   StrMap.empty
  , libWarnings: StrMap.empty
  , libErrors:   StrMap.empty
  }

-- | Annotates a error/warning result set with original source lines, better
-- | positions, and semantic paths (lib vs src). The callback should load the
-- | requested set of lines from the absolute filename based on the tentative
-- | position information.
output
  :: forall m
   . (Monad m)
  => (Filename -> Position -> m (Maybe Lines))
  -> PsaOptions
  -> PsaResult
  -> m Output
output loadLines options result = do
  state  <- Array.foldM (onError Warning) initialState result'.warnings
  state' <- Array.foldM (onError Error) state result'.errors
  pure state'
    { warnings = Array.sortBy compareByLocation state'.warnings
    , errors = Array.sortBy compareByLocation state'.errors
    }

  where
  initialState =
    { warnings: []
    , errors: []
    , stats: initialStats
    }

  result' =
    if not options.strict
      then { warnings, errors }
      else
        let split = partition (isSrc <<< fst) warnings
         in { warnings: split.fail, errors: errors <> split.pass }
    where
      warnings = pathOf <$> result.warnings
      errors = pathOf <$> result.errors

  pathOf :: PsaError -> Tuple PsaPath PsaError
  pathOf x =
    case x.filename of
      Just f  -> Tuple (errorPath options.libDirs f (Path.relative options.cwd f)) x
      Nothing -> Tuple Unknown x

  onError :: ErrorTag -> Output -> Tuple PsaPath PsaError -> m Output
  onError tag state (Tuple path error) =
    if shouldShowError options tag path error.errorCode
      then do
        source <- fromMaybe (pure Nothing) (loadLines <$> error.filename <*> error.position)
        let position = trimPosition <$> source <*> error.position
            source' = (\p -> Array.take (p.endLine - p.startLine + 1)) <$> position <*> source
        update [{ error: error { message = trimMessage error.message }, path, position, source: source' }]
      else
        update []

    where
    update :: Array PsaAnnotedError -> m Output
    update log =
      pure $ onTag
        (_ { stats = stats, errors = state.errors <> log })
        (_ { stats = stats, warnings = state.warnings <> log })
        tag state
      where
      stats = updateStats tag path error.errorCode (not (Array.null log)) state.stats

partition :: forall a. (a -> Boolean) -> Array a -> { pass :: Array a, fail :: Array a }
partition f = foldl go { pass: [], fail: [] }
  where
  go { pass, fail } x =
    if f x
      then { pass: Array.snoc pass x, fail }
      else { pass, fail: Array.snoc fail x }

updateStats
  :: ErrorTag
  -> PsaPath
  -> String
  -> Boolean -- If the error was printed
  -> OutputStats
  -> OutputStats
updateStats tag path code printed s =
  { allWarnings: onTag id bumpCode tag s.allWarnings
  , allErrors:   onTag bumpCode id tag s.allErrors
  , srcWarnings: onTag id (onPath bumpCode id path) tag s.srcWarnings
  , srcErrors:   onTag (onPath bumpCode id path) id tag s.srcErrors
  , libWarnings: onTag id (onPath id bumpCode path) tag s.libWarnings
  , libErrors:   onTag (onPath id bumpCode path) id tag s.libErrors
  }

  where
  bumpCode = StrMap.alter alterStat code
  bump (Tuple a b) = Tuple (if printed then a + 1 else a) (b + 1)
  alterStat Nothing  = Just (bump (Tuple 0 0))
  alterStat (Just x) = Just (bump x)

shouldShowError :: PsaOptions -> ErrorTag -> PsaPath -> String -> Boolean
shouldShowError { filterCodes, censorCodes, censorSrc, censorLib, censorWarnings } tag path code =
  not (censorWarnings && isWarning tag)
  && not (censorSrc && isSrc path || censorLib && isLib path)
  && (Set.isEmpty filterCodes || Set.member code filterCodes)
  && (Set.isEmpty censorCodes || not (Set.member code censorCodes))

errorPath :: Array String -> String -> String -> PsaPath
errorPath libDirs path short =
  if any (path `startsWith` _) libDirs
    then Lib short
    else Src short
  where
  startsWith s' s =
    case Str.indexOf s s' of
      Just 0 -> true
      _      -> false

onTag :: forall a b. (a -> b) -> (a -> b) -> ErrorTag -> a -> b
onTag f g Error   x = f x
onTag f g Warning x = g x

onPath :: forall a. (a -> a) -> (a -> a) -> PsaPath -> a -> a
onPath f g (Src _) x = f x
onPath f g (Lib _) x = g x
onPath f g _       x = x

isLib :: PsaPath -> Boolean
isLib (Lib _) = true
isLib _       = false

isSrc :: PsaPath -> Boolean
isSrc (Src _) = true
isSrc _       = false

isWarning :: ErrorTag -> Boolean
isWarning Warning = true
isWarning _       = false

-- | Finds the true bounds of the source. The PureScript compiler is greedy
-- | when it comes to matching whitespace at the end of an expression, so the
-- | original source bounds always includes whitespace and comments.
trimPosition :: Lines -> Position -> Position
trimPosition lines pos =
  case lines of
    [] ->
      { startLine: pos.startLine
      , startColumn: pos.startColumn
      , endLine: pos.startLine
      , endColumn: pos.startColumn
      }

    [l] ->
      case trimCol (pos.endColumn) l of
        Just col -> pos { endLine = pos.startLine, endColumn = col }
        Nothing  -> pos { endLine = pos.startLine, endColumn = pos.startColumn }

    _ ->
      case trimPos { row: pos.endLine, col: pos.endColumn } of
        Just { row, col } -> pos { endLine = row, endColumn = col }
        Nothing           -> trimPosition [] pos

  where
  -- WARNING: here be off-by-one dragons!

  trimPos { row, col }
    | col <= 1 =
      case Array.index lines (row - pos.startLine - 1) of
        Just l -> trimPos { row: row - 1, col: Str.length l + 1 }
        _      -> Nothing

    | otherwise =
      case Array.index lines (row - pos.startLine) of
        Just l ->
          case trimCol col l of
            Just col' -> Just { row, col: col' }
            Nothing   -> trimPos { row, col: 1 }

        _      -> Nothing

  trimCol col l =
    case Str.charAt (col - 2) l of
      Just x | isPunc x -> trimCol (col - 1) l
      Just _            -> trimComment col l
      _                 -> Nothing

  -- TODO: this breaks if "--" is inside a quoted string.
  -- TODO: Block comments?
  trimComment col l =
    case Str.indexOf "--" l of
      Just x | x == 0        -> Nothing
      Just x | x < (col - 1) -> trimCol (x + 1) l
      _                      -> Just col

  isPunc ' ' = true
  isPunc ',' = true
  isPunc _   = false

-- | Trims extraneous whitespace from psc error messages.
trimMessage :: String -> String
trimMessage =
  Str.split "\n"
  >>> foldl dedent { lines: [], indent: top }
  >>> _.lines
  >>> foldl collapse []
  >>> Str.joinWith "\n"
  >>> Str.trim

  where
  dedent { lines, indent } l
    | l == ""   = { lines: Array.snoc lines l, indent }
    | otherwise =
      let indent' = Str.length $ Str.takeWhile (_ == ' ') l in
      if indent' < indent
        then { lines: Array.snoc lines (Str.drop indent' l), indent: indent' }
        else { lines: Array.snoc lines (Str.drop indent l), indent }

  collapse lines l =
    case Array.last lines of
      Just "" | l == "" -> lines
      _                 -> Array.snoc lines l