Spacing

Spacing

module Data.Generic
  ( class Generic
  , toSpine
  , toSignature
  , fromSpine
  , GenericSpine(..)
  , GenericSignature(..)
  , DataConstructor
  , showDataConstructor
  , showSignature
  , isValidSpine
  , gShow
  , gEq
  , gCompare
  ) where

import Prelude

import Data.Array (null, length, sortBy, zipWith)
import Data.Either (Either(..))
import Data.Foldable (all, and, find, fold, intercalate)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty(..))
import Data.String (joinWith)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))

import Type.Proxy (Proxy(..))

-- | The Generic typeclass provides methods for sending data to/from spine
-- | representations, as well as querying about the signatures of spine
-- | representations.
-- |
-- | For standard data structures, you can simply write
-- | `derive instance genericFoo :: Generic Foo` in the module they are
-- | declared, and the instance methods will be filled in for you.
class Generic a where
  toSpine :: a -> GenericSpine
  toSignature :: Proxy a -> GenericSignature
  fromSpine :: GenericSpine -> Maybe a

instance genericNumber :: Generic Number where
  toSpine = SNumber
  toSignature _ = SigNumber
  fromSpine (SNumber n) = Just n
  fromSpine _ = Nothing

instance genericInt :: Generic Int where
  toSpine = SInt
  toSignature _ = SigInt
  fromSpine (SInt n) = Just n
  fromSpine _ = Nothing

instance genericString :: Generic String where
  toSpine = SString
  toSignature _ = SigString
  fromSpine (SString s) = Just s
  fromSpine _ = Nothing

instance genericChar :: Generic Char where
  toSpine = SChar
  toSignature _ = SigChar
  fromSpine (SChar s) = Just s
  fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
  toSpine = SBoolean
  toSignature _ = SigBoolean
  fromSpine (SBoolean b) = Just b
  fromSpine _ = Nothing

instance genericArray :: Generic a => Generic (Array a) where
  toSpine = SArray <<< map (\x _ -> toSpine x)
  toSignature x = SigArray (\_ -> toSignature (lowerProxy x))
    where
    lowerProxy :: Proxy (Array a) -> Proxy a
    lowerProxy _ = Proxy
  fromSpine (SArray x) = traverse (fromSpine <<< force) x
  fromSpine _ = Nothing

instance genericUnit :: Generic Unit where
  toSpine _ = SUnit
  toSignature _ = SigUnit
  fromSpine SUnit = Just unit
  fromSpine _ = Nothing

instance genericVoid :: Generic Void where
  toSpine = absurd
  toSignature _ = SigProd "Data.Void.Void" []
  fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
  toSpine (Tuple x y) =
    SProd "Data.Tuple.Tuple" [\_ -> toSpine x, \_ -> toSpine y]
  toSignature x =
    SigProd
      "Data.Tuple.Tuple"
      [ { sigConstructor: "Data.Tuple.Tuple"
        , sigValues:
            [ \_ -> toSignature (fstProxy x)
            , \_ -> toSignature (sndProxy x)
            ]
        }
      ]
    where
    fstProxy :: Proxy (Tuple a b) -> Proxy a
    fstProxy _ = Proxy
    sndProxy :: Proxy (Tuple a b) -> Proxy b
    sndProxy _ = Proxy
  fromSpine (SProd "Data.Tuple.Tuple" [x, y]) =
    Tuple <$> fromSpine (force x) <*> fromSpine (force y)
  fromSpine _ = Nothing

instance genericMaybe :: Generic a => Generic (Maybe a) where
  toSpine (Just x) = SProd "Data.Maybe.Just" [\_ -> toSpine x]
  toSpine Nothing = SProd "Data.Maybe.Nothing" []
  toSignature x =
    SigProd
      "Data.Maybe.Maybe"
      [ { sigConstructor: "Data.Maybe.Just"
        , sigValues: [\_ -> toSignature (mbProxy x)]
        }
      , { sigConstructor: "Data.Maybe.Nothing"
        , sigValues: []
        }
      ]
    where
    mbProxy :: Proxy (Maybe a) -> Proxy a
    mbProxy _ = Proxy
  fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (force x)
  fromSpine (SProd "Data.Maybe.Nothing" []) = pure Nothing
  fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
  toSpine (Left x) = SProd "Data.Either.Left" [\_ -> toSpine x]
  toSpine (Right x) = SProd "Data.Either.Right" [\_ -> toSpine x]
  toSignature x =
    SigProd
      "Data.Either.Either"
      [ { sigConstructor: "Data.Either.Left"
        , sigValues: [\_ -> toSignature (lproxy x)]
        }
      , { sigConstructor: "Data.Either.Right"
        , sigValues: [\_ -> toSignature (rproxy x)]
        }
      ]
    where
    lproxy :: Proxy (Either a b) -> Proxy a
    lproxy _ = Proxy
    rproxy :: Proxy (Either a b) -> Proxy b
    rproxy _ = Proxy
  fromSpine (SProd "Data.Either.Left" [x]) = Left <$> fromSpine (force x)
  fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (force x)
  fromSpine _ = Nothing

instance genericIdentity :: (Generic a) => Generic (Identity a) where
  toSpine (Identity a) = SProd "Data.Identity.Identity" [\_ -> toSpine a]
  toSignature x =
    SigProd
      "Data.Identity.Identity"
      [ { sigConstructor: "Data.Identity.Identity"
        , sigValues: [\_ -> toSignature (iproxy x)]
        }
      ]
    where
    iproxy :: Proxy (Identity a) -> Proxy a
    iproxy _ = Proxy
  fromSpine (SProd "Data.Identity.Identity" [x]) = Identity <$> fromSpine (force x)
  fromSpine _ = Nothing

instance genericOrdering :: Generic Ordering where
  toSpine = case _ of
    LT -> SProd "Data.Ordering.LT" []
    EQ -> SProd "Data.Ordering.EQ" []
    GT -> SProd "Data.Ordering.GT" []
  toSignature _ =
    SigProd
      "Data.Ordering.Ordering"
      [ { sigConstructor: "Data.Ordering.LT", sigValues: [] }
      , { sigConstructor: "Data.Ordering.EQ", sigValues: [] }
      , { sigConstructor: "Data.Ordering.GT", sigValues: [] }
      ]
  fromSpine = case _ of
    SProd "Data.Ordering.LT" [] -> Just LT
    SProd "Data.Ordering.EQ" [] -> Just EQ
    SProd "Data.Ordering.GT" [] -> Just GT
    _ -> Nothing

instance genericNonEmpty :: (Generic (f a), Generic a) => Generic (NonEmpty f a) where
  toSpine (NonEmpty x xs) =
    SProd "Data.NonEmpty.NonEmpty" [\_ -> toSpine x, \_ -> toSpine xs]
  toSignature x =
    SigProd
      "Data.NonEmpty.NonEmpty"
      [ { sigConstructor: "Data.NonEmpty.NonEmpty"
        , sigValues:
            [ \_ -> toSignature (headProxy x)
            , \_ -> toSignature (tailProxy x)
            ]
        }
      ]
    where
    headProxy :: Proxy (NonEmpty f a) -> Proxy a
    headProxy _ = Proxy
    tailProxy :: Proxy (NonEmpty f a) -> Proxy (f a)
    tailProxy _ = Proxy
  fromSpine (SProd "Data.NonEmpty.NonEmpty" [x, xs]) =
    NonEmpty <$> fromSpine (force x) <*> fromSpine (force xs)
  fromSpine _ = Nothing

-- | A GenericSpine is a universal representation of an arbitrary data
-- | structure (that does not contain function arrows).
data GenericSpine
  = SProd String (Array (Unit -> GenericSpine))
  | SRecord (Array { recLabel :: String, recValue :: Unit -> GenericSpine })
  | SNumber Number
  | SBoolean Boolean
  | SInt Int
  | SString String
  | SChar Char
  | SArray (Array (Unit -> GenericSpine))
  | SUnit

instance showGenericSpine :: Show GenericSpine
    where
        show  SUnit            = "SUnit"
        show (SChar         c) = "SChar "    <> show  c
        show (SString       s) = "SString "  <> show  s
        show (SBoolean      b) = "SBoolean " <> show  b
        show (SNumber       n) = "SNumber "  <> show  n
        show (SInt          i) = "SInt "     <> show  i
        show (SArray      arr) = "SArray "   <> showArray showSuspended arr
        show (SProd   lbl arr) = "SProd "    <> show  lbl <> " "
                                             <> showArray showSuspended arr
        show (SRecord     arr) = "SRecord "  <> showArray showElt       arr
            where
                showElt { recLabel: label, recValue: value } =
                    fold ["{ recLabel: ", show label, ", recValue: ", showSuspended value, " }"]

-- | Shows a lazily evaluated value under a function with `Unit` parameter.
showSuspended  :: forall a. Show a => (Unit -> a) -> String
showSuspended e = "\\_ -> " <> show (e unit)

instance eqGenericSpine :: Eq GenericSpine where
  eq (SProd s1 arr1) (SProd s2 arr2) =
    s1 == s2 && length arr1 == length arr2 && zipAll eqThunk arr1 arr2
  eq (SRecord arr1) (SRecord arr2) = eqRecordSigs arr1 arr2
  eq (SNumber x) (SNumber y) = x == y
  eq (SBoolean x) (SBoolean y) = x == y
  eq (SInt x) (SInt y) = x == y
  eq (SString x) (SString y) = x == y
  eq (SChar x) (SChar y) = x == y
  eq (SArray xs) (SArray ys) = length xs == length ys && zipAll eqThunk xs ys
  eq SUnit SUnit = true
  eq _ _ = false

instance ordGenericSpine :: Ord GenericSpine where
  compare (SProd s1 arr1) (SProd s2 arr2) =
    case compare s1 s2 of
      EQ -> compare 0 $ zipCompare compareThunk arr1 arr2
      c1 -> c1
  compare (SProd _ _) _ = LT
  compare _ (SProd _ _) = GT
  compare (SRecord xs) (SRecord ys) =
    compare 0 $ zipCompare go xs ys
    where
    go x y = case compare x.recLabel y.recLabel of
      EQ -> orderingToInt $ compare (force x.recValue) (force y.recValue)
      c -> orderingToInt c
  compare (SRecord _) _ = LT
  compare _ (SRecord _) = GT
  compare (SInt x) (SInt y) = compare x y
  compare (SInt _) _ = LT
  compare _ (SInt _) = GT
  compare (SBoolean x) (SBoolean y) = compare x y
  compare (SBoolean _) _ = LT
  compare _ (SBoolean _) = GT
  compare (SNumber x) (SNumber y) = compare x y
  compare (SNumber _) _ = LT
  compare _ (SNumber _) = GT
  compare (SString x) (SString y) = compare x y
  compare (SString _) _ = LT
  compare _ (SString _) = GT
  compare (SChar x) (SChar y) = compare x y
  compare (SChar _) _ = LT
  compare _ (SChar _) = GT
  compare (SArray xs) (SArray ys) = compare 0 $ zipCompare compareThunk xs ys
  compare (SArray _) _ = LT
  compare _ (SArray _) = GT
  compare SUnit SUnit = EQ

-- | A GenericSignature is a universal representation of the structure of an
-- | arbitrary data structure (that does not contain function arrows).
data GenericSignature
  = SigProd String (Array DataConstructor)
  | SigRecord (Array { recLabel :: String, recValue :: Unit -> GenericSignature })
  | SigNumber
  | SigBoolean
  | SigInt
  | SigString
  | SigChar
  | SigArray (Unit -> GenericSignature)
  | SigUnit

instance eqGenericSignature :: Eq GenericSignature where
  eq (SigProd s1 arr1) (SigProd s2 arr2) =
    s1 == s2 && length arr1 == length arr2 && zipAll eqDataConstructor arr1 arr2
  eq (SigRecord arr1) (SigRecord arr2) = eqRecordSigs arr1 arr2
  eq SigNumber SigNumber = true
  eq SigBoolean SigBoolean = true
  eq SigInt SigInt = true
  eq SigString SigString = true
  eq SigChar SigChar = true
  eq (SigArray t1) (SigArray t2) = eqThunk t1 t2
  eq SigUnit SigUnit = true
  eq _ _ = false

instance showGenericSignature :: Show GenericSignature where
  show = showSignature

-- | Identifies a data constructor.
type DataConstructor =
  { sigConstructor :: String
  , sigValues :: Array (Unit -> GenericSignature)
  }

eqDataConstructor :: DataConstructor -> DataConstructor -> Boolean
eqDataConstructor p1 p2
  = p1.sigConstructor == p2.sigConstructor
  && zipAll eqThunk p1.sigValues p2.sigValues

showDataConstructor :: DataConstructor -> String
showDataConstructor dc =
  "{ sigConstructor: " <> show dc.sigConstructor <>
  ", sigValues: " <> showArray (showSignature <<< force) dc.sigValues <>
  " }"

showSignature :: GenericSignature -> String
showSignature sig =
  fold $ case sig of
    SigProd tyName ctors ->
      ["SigProd ", show tyName, " ", showArray showDataConstructor ctors]
    SigRecord labels -> ["SigRecord ", showArray showLabel labels]
    SigNumber -> ["SigNumber"]
    SigBoolean -> ["SigBoolean"]
    SigInt -> ["SigInt"]
    SigString -> ["SigString"]
    SigChar -> ["SigChar"]
    SigArray sig' -> ["SigArray ", paren (force sig')]
    SigUnit -> ["SigUnit"]

  where
  paren s
    | needsParen s = "(" <> showSignature s <> ")"
    | otherwise = showSignature s

  needsParen s = case s of
    SigProd _ _ -> true
    SigRecord _ -> true
    SigNumber -> false
    SigBoolean -> false
    SigInt -> false
    SigString -> false
    SigChar -> false
    SigArray _ -> true
    SigUnit -> false

-- We use this instead of the default Show Array instance to avoid escaping
-- strings twice.
showArray :: forall a. (a -> String) -> Array a -> String
showArray _ [] = "[]"
showArray f xs = "[ " <> intercalate ", " (map f xs) <> " ]"

showLabel
  :: { recLabel :: String, recValue :: Unit -> GenericSignature }
  -> String
showLabel l =
  "{ recLabel: " <> show l.recLabel <>
  ", recValue: " <> showSignature (force l.recValue) <>
  " }"

-- | Checks that the spine follows the structure defined by the signature
isValidSpine :: GenericSignature -> GenericSpine -> Boolean
isValidSpine SigBoolean (SBoolean _) = true
isValidSpine SigNumber (SNumber _) = true
isValidSpine SigInt (SInt _) = true
isValidSpine SigString (SString _) = true
isValidSpine SigChar (SChar _) = true
isValidSpine (SigArray sig) (SArray spines) =
  all (isValidSpine (force sig) <<< force) spines
isValidSpine (SigProd _ alts) (SProd tag values) =
  case find (\alt -> alt.sigConstructor == tag) alts of
    Nothing -> false
    Just { sigValues } ->
      and $ zipWith
        (\sig spine -> isValidSpine (force sig) (force spine))
        sigValues
        values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith
    (\sig val -> isValidSpine (force sig.recValue) (force val.recValue))
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine SigUnit SUnit = true
isValidSpine _ _ = false

-- ## Generic Functions

-- | This function can be used as the default instance for Show for any
-- | instance of Generic
gShow :: forall a. Generic a => a -> String
gShow = genericShowPrec 0 <<< toSpine

genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr)
  | null arr = s
  | otherwise =
      showParen (d > 10) $
        s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (force x)) arr)
      where
      showParen false x = x
      showParen true  x = "(" <> x <> ")"
genericShowPrec _ (SRecord xs) =
  "{" <> joinWith ", " (map showLabelPart xs) <> "}"
  where
  showLabelPart x = x.recLabel <> ": " <> genericShowPrec 0 (force x.recValue)
genericShowPrec _ (SBoolean x) = show x
genericShowPrec _ (SInt x) = show x
genericShowPrec _ (SNumber x) = show x
genericShowPrec _ (SString x) = show x
genericShowPrec _ (SChar x) = show x
genericShowPrec _ (SArray xs) =
  "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (force x)) xs) <> "]"
genericShowPrec _ SUnit = "unit"

-- | This function can be used as an implementation of the `eq` function of `Eq`
-- | for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Eq` instances
-- | rather than relying on `gEq`, where possible.
gEq :: forall a. Generic a => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

-- | This function can be used as an implementation of the `compare` function
-- | of `Ord` for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Ord` instances
-- | rather than relying on `gCompare`, where possible.
gCompare :: forall a. Generic a => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)

-- ## Internal functions

foreign import zipAll
  :: forall a b
   . (a -> b -> Boolean)
  -> Array a
  -> Array b
  -> Boolean

foreign import zipCompare
  :: forall a b
   . (a -> b -> Int)
  -> Array a
  -> Array b
  -> Int

force :: forall a. (Unit -> a) -> a
force f = f unit

compareThunk :: forall a. Ord a => (Unit -> a) -> (Unit -> a) -> Int
compareThunk x y = orderingToInt $ compare (force x) (force y)

eqThunk :: forall a. Eq a => (Unit -> a) -> (Unit -> a) -> Boolean
eqThunk x y = force x == force y

eqRecordSigs
  :: forall a
   . Eq a
  => Array {recLabel :: String, recValue :: Unit -> a}
  -> Array {recLabel :: String, recValue :: Unit -> a}
  -> Boolean
eqRecordSigs arr1 arr2 =
  length arr1 == length arr2 && zipAll doCmp sorted1 sorted2
  where
  labelCompare r1 r2 = compare r1.recLabel r2.recLabel
  sorted1 = sortBy labelCompare arr1
  sorted2 = sortBy labelCompare arr2
  doCmp x y = x.recLabel == y.recLabel && force x.recValue == force y.recValue

orderingToInt :: Ordering -> Int
orderingToInt = case _ of
  EQ -> 0
  LT -> 1
  GT -> -1

module Data.Generic
  ( class Generic
  , toSpine
  , toSignature
  , fromSpine
  , GenericSpine(..)
  , GenericSignature(..)
  , DataConstructor
  , showDataConstructor
  , showSignature
  , isValidSpine
  , gShow
  , gEq
  , gCompare
  ) where

import Prelude

import Data.Array (null, length, sortBy, zipWith)
import Data.Either (Either(..))
import Data.Foldable (all, and, find, fold, intercalate)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty(..))
import Data.String (joinWith)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))

import Type.Proxy (Proxy(..))

-- | The Generic typeclass provides methods for sending data to/from spine
-- | representations, as well as querying about the signatures of spine
-- | representations.
-- |
-- | For standard data structures, you can simply write
-- | `derive instance genericFoo :: Generic Foo` in the module they are
-- | declared, and the instance methods will be filled in for you.
class Generic a where
  toSpine :: a -> GenericSpine
  toSignature :: Proxy a -> GenericSignature
  fromSpine :: GenericSpine -> Maybe a

instance genericNumber :: Generic Number where
  toSpine = SNumber
  toSignature _ = SigNumber
  fromSpine (SNumber n) = Just n
  fromSpine _ = Nothing

instance genericInt :: Generic Int where
  toSpine = SInt
  toSignature _ = SigInt
  fromSpine (SInt n) = Just n
  fromSpine _ = Nothing

instance genericString :: Generic String where
  toSpine = SString
  toSignature _ = SigString
  fromSpine (SString s) = Just s
  fromSpine _ = Nothing

instance genericChar :: Generic Char where
  toSpine = SChar
  toSignature _ = SigChar
  fromSpine (SChar s) = Just s
  fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
  toSpine = SBoolean
  toSignature _ = SigBoolean
  fromSpine (SBoolean b) = Just b
  fromSpine _ = Nothing

instance genericArray :: Generic a => Generic (Array a) where
  toSpine = SArray <<< map (\x _ -> toSpine x)
  toSignature x = SigArray (\_ -> toSignature (lowerProxy x))
    where
    lowerProxy :: Proxy (Array a) -> Proxy a
    lowerProxy _ = Proxy
  fromSpine (SArray x) = traverse (fromSpine <<< force) x
  fromSpine _ = Nothing

instance genericUnit :: Generic Unit where
  toSpine _ = SUnit
  toSignature _ = SigUnit
  fromSpine SUnit = Just unit
  fromSpine _ = Nothing

instance genericVoid :: Generic Void where
  toSpine = absurd
  toSignature _ = SigProd "Data.Void.Void" []
  fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
  toSpine (Tuple x y) =
    SProd "Data.Tuple.Tuple" [\_ -> toSpine x, \_ -> toSpine y]
  toSignature x =
    SigProd
      "Data.Tuple.Tuple"
      [ { sigConstructor: "Data.Tuple.Tuple"
        , sigValues:
            [ \_ -> toSignature (fstProxy x)
            , \_ -> toSignature (sndProxy x)
            ]
        }
      ]
    where
    fstProxy :: Proxy (Tuple a b) -> Proxy a
    fstProxy _ = Proxy
    sndProxy :: Proxy (Tuple a b) -> Proxy b
    sndProxy _ = Proxy
  fromSpine (SProd "Data.Tuple.Tuple" [x, y]) =
    Tuple <$> fromSpine (force x) <*> fromSpine (force y)
  fromSpine _ = Nothing

instance genericMaybe :: Generic a => Generic (Maybe a) where
  toSpine (Just x) = SProd "Data.Maybe.Just" [\_ -> toSpine x]
  toSpine Nothing = SProd "Data.Maybe.Nothing" []
  toSignature x =
    SigProd
      "Data.Maybe.Maybe"
      [ { sigConstructor: "Data.Maybe.Just"
        , sigValues: [\_ -> toSignature (mbProxy x)]
        }
      , { sigConstructor: "Data.Maybe.Nothing"
        , sigValues: []
        }
      ]
    where
    mbProxy :: Proxy (Maybe a) -> Proxy a
    mbProxy _ = Proxy
  fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (force x)
  fromSpine (SProd "Data.Maybe.Nothing" []) = pure Nothing
  fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
  toSpine (Left x) = SProd "Data.Either.Left" [\_ -> toSpine x]
  toSpine (Right x) = SProd "Data.Either.Right" [\_ -> toSpine x]
  toSignature x =
    SigProd
      "Data.Either.Either"
      [ { sigConstructor: "Data.Either.Left"
        , sigValues: [\_ -> toSignature (lproxy x)]
        }
      , { sigConstructor: "Data.Either.Right"
        , sigValues: [\_ -> toSignature (rproxy x)]
        }
      ]
    where
    lproxy :: Proxy (Either a b) -> Proxy a
    lproxy _ = Proxy
    rproxy :: Proxy (Either a b) -> Proxy b
    rproxy _ = Proxy
  fromSpine (SProd "Data.Either.Left" [x]) = Left <$> fromSpine (force x)
  fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (force x)
  fromSpine _ = Nothing

instance genericIdentity :: (Generic a) => Generic (Identity a) where
  toSpine (Identity a) = SProd "Data.Identity.Identity" [\_ -> toSpine a]
  toSignature x =
    SigProd
      "Data.Identity.Identity"
      [ { sigConstructor: "Data.Identity.Identity"
        , sigValues: [\_ -> toSignature (iproxy x)]
        }
      ]
    where
    iproxy :: Proxy (Identity a) -> Proxy a
    iproxy _ = Proxy
  fromSpine (SProd "Data.Identity.Identity" [x]) = Identity <$> fromSpine (force x)
  fromSpine _ = Nothing

instance genericOrdering :: Generic Ordering where
  toSpine = case _ of
    LT -> SProd "Data.Ordering.LT" []
    EQ -> SProd "Data.Ordering.EQ" []
    GT -> SProd "Data.Ordering.GT" []
  toSignature _ =
    SigProd
      "Data.Ordering.Ordering"
      [ { sigConstructor: "Data.Ordering.LT", sigValues: [] }
      , { sigConstructor: "Data.Ordering.EQ", sigValues: [] }
      , { sigConstructor: "Data.Ordering.GT", sigValues: [] }
      ]
  fromSpine = case _ of
    SProd "Data.Ordering.LT" [] -> Just LT
    SProd "Data.Ordering.EQ" [] -> Just EQ
    SProd "Data.Ordering.GT" [] -> Just GT
    _ -> Nothing

instance genericNonEmpty :: (Generic (f a), Generic a) => Generic (NonEmpty f a) where
  toSpine (NonEmpty x xs) =
    SProd "Data.NonEmpty.NonEmpty" [\_ -> toSpine x, \_ -> toSpine xs]
  toSignature x =
    SigProd
      "Data.NonEmpty.NonEmpty"
      [ { sigConstructor: "Data.NonEmpty.NonEmpty"
        , sigValues:
            [ \_ -> toSignature (headProxy x)
            , \_ -> toSignature (tailProxy x)
            ]
        }
      ]
    where
    headProxy :: Proxy (NonEmpty f a) -> Proxy a
    headProxy _ = Proxy
    tailProxy :: Proxy (NonEmpty f a) -> Proxy (f a)
    tailProxy _ = Proxy
  fromSpine (SProd "Data.NonEmpty.NonEmpty" [x, xs]) =
    NonEmpty <$> fromSpine (force x) <*> fromSpine (force xs)
  fromSpine _ = Nothing

-- | A GenericSpine is a universal representation of an arbitrary data
-- | structure (that does not contain function arrows).
data GenericSpine
  = SProd String (Array (Unit -> GenericSpine))
  | SRecord (Array { recLabel :: String, recValue :: Unit -> GenericSpine })
  | SNumber Number
  | SBoolean Boolean
  | SInt Int
  | SString String
  | SChar Char
  | SArray (Array (Unit -> GenericSpine))
  | SUnit

instance showGenericSpine :: Show GenericSpine
    where
        show  SUnit            = "SUnit"
        show (SChar         c) = "SChar "    <> show  c
        show (SString       s) = "SString "  <> show  s
        show (SBoolean      b) = "SBoolean " <> show  b
        show (SNumber       n) = "SNumber "  <> show  n
        show (SInt          i) = "SInt "     <> show  i
        show (SArray      arr) = "SArray "   <> showArray showSuspended arr
        show (SProd   lbl arr) = "SProd "    <> show  lbl <> " "
                                             <> showArray showSuspended arr
        show (SRecord     arr) = "SRecord "  <> showArray showElt       arr
            where
                showElt { recLabel: label, recValue: value } =
                    fold ["{ recLabel: ", show label, ", recValue: ", showSuspended value, "}"]

-- | Shows a lazily evaluated value under a function with `Unit` parameter.
showSuspended  :: forall a. Show a => (Unit -> a) -> String
showSuspended e = "\\_->" <> show (e unit)

instance eqGenericSpine :: Eq GenericSpine where
  eq (SProd s1 arr1) (SProd s2 arr2) =
    s1 == s2 && length arr1 == length arr2 && zipAll eqThunk arr1 arr2
  eq (SRecord arr1) (SRecord arr2) = eqRecordSigs arr1 arr2
  eq (SNumber x) (SNumber y) = x == y
  eq (SBoolean x) (SBoolean y) = x == y
  eq (SInt x) (SInt y) = x == y
  eq (SString x) (SString y) = x == y
  eq (SChar x) (SChar y) = x == y
  eq (SArray xs) (SArray ys) = length xs == length ys && zipAll eqThunk xs ys
  eq SUnit SUnit = true
  eq _ _ = false

instance ordGenericSpine :: Ord GenericSpine where
  compare (SProd s1 arr1) (SProd s2 arr2) =
    case compare s1 s2 of
      EQ -> compare 0 $ zipCompare compareThunk arr1 arr2
      c1 -> c1
  compare (SProd _ _) _ = LT
  compare _ (SProd _ _) = GT
  compare (SRecord xs) (SRecord ys) =
    compare 0 $ zipCompare go xs ys
    where
    go x y = case compare x.recLabel y.recLabel of
      EQ -> orderingToInt $ compare (force x.recValue) (force y.recValue)
      c -> orderingToInt c
  compare (SRecord _) _ = LT
  compare _ (SRecord _) = GT
  compare (SInt x) (SInt y) = compare x y
  compare (SInt _) _ = LT
  compare _ (SInt _) = GT
  compare (SBoolean x) (SBoolean y) = compare x y
  compare (SBoolean _) _ = LT
  compare _ (SBoolean _) = GT
  compare (SNumber x) (SNumber y) = compare x y
  compare (SNumber _) _ = LT
  compare _ (SNumber _) = GT
  compare (SString x) (SString y) = compare x y
  compare (SString _) _ = LT
  compare _ (SString _) = GT
  compare (SChar x) (SChar y) = compare x y
  compare (SChar _) _ = LT
  compare _ (SChar _) = GT
  compare (SArray xs) (SArray ys) = compare 0 $ zipCompare compareThunk xs ys
  compare (SArray _) _ = LT
  compare _ (SArray _) = GT
  compare SUnit SUnit = EQ

-- | A GenericSignature is a universal representation of the structure of an
-- | arbitrary data structure (that does not contain function arrows).
data GenericSignature
  = SigProd String (Array DataConstructor)
  | SigRecord (Array { recLabel :: String, recValue :: Unit -> GenericSignature })
  | SigNumber
  | SigBoolean
  | SigInt
  | SigString
  | SigChar
  | SigArray (Unit -> GenericSignature)
  | SigUnit

instance eqGenericSignature :: Eq GenericSignature where
  eq (SigProd s1 arr1) (SigProd s2 arr2) =
    s1 == s2 && length arr1 == length arr2 && zipAll eqDataConstructor arr1 arr2
  eq (SigRecord arr1) (SigRecord arr2) = eqRecordSigs arr1 arr2
  eq SigNumber SigNumber = true
  eq SigBoolean SigBoolean = true
  eq SigInt SigInt = true
  eq SigString SigString = true
  eq SigChar SigChar = true
  eq (SigArray t1) (SigArray t2) = eqThunk t1 t2
  eq SigUnit SigUnit = true
  eq _ _ = false

instance showGenericSignature :: Show GenericSignature where
  show = showSignature

-- | Identifies a data constructor.
type DataConstructor =
  { sigConstructor :: String
  , sigValues :: Array (Unit -> GenericSignature)
  }

eqDataConstructor :: DataConstructor -> DataConstructor -> Boolean
eqDataConstructor p1 p2
  = p1.sigConstructor == p2.sigConstructor
  && zipAll eqThunk p1.sigValues p2.sigValues

showDataConstructor :: DataConstructor -> String
showDataConstructor dc =
  "{ sigConstructor: " <> show dc.sigConstructor <>
  ", sigValues: " <> showArray (showSignature <<< force) dc.sigValues <>
  "}"

showSignature :: GenericSignature -> String
showSignature sig =
  fold $ case sig of
    SigProd tyName ctors ->
      ["SigProd ", show tyName, " ", showArray showDataConstructor ctors]
    SigRecord labels -> ["SigRecord ", showArray showLabel labels]
    SigNumber -> ["SigNumber"]
    SigBoolean -> ["SigBoolean"]
    SigInt -> ["SigInt"]
    SigString -> ["SigString"]
    SigChar -> ["SigChar"]
    SigArray sig' -> ["SigArray ", paren (force sig')]
    SigUnit -> ["SigUnit"]

  where
  paren s
    | needsParen s = "(" <> showSignature s <> ")"
    | otherwise = showSignature s

  needsParen s = case s of
    SigProd _ _ -> true
    SigRecord _ -> true
    SigNumber -> false
    SigBoolean -> false
    SigInt -> false
    SigString -> false
    SigChar -> false
    SigArray _ -> true
    SigUnit -> false

-- We use this instead of the default Show Array instance to avoid escaping
-- strings twice.
showArray :: forall a. (a -> String) -> Array a -> String
showArray _ [] = "[]"
showArray f xs = "[ " <> intercalate ", " (map f xs) <> " ]"

showLabel
  :: { recLabel :: String, recValue :: Unit -> GenericSignature }
  -> String
showLabel l =
  "{ recLabel: " <> show l.recLabel <>
  ", recValue: " <> showSignature (force l.recValue) <>
  " }"

-- | Checks that the spine follows the structure defined by the signature
isValidSpine :: GenericSignature -> GenericSpine -> Boolean
isValidSpine SigBoolean (SBoolean _) = true
isValidSpine SigNumber (SNumber _) = true
isValidSpine SigInt (SInt _) = true
isValidSpine SigString (SString _) = true
isValidSpine SigChar (SChar _) = true
isValidSpine (SigArray sig) (SArray spines) =
  all (isValidSpine (force sig) <<< force) spines
isValidSpine (SigProd _ alts) (SProd tag values) =
  case find (\alt -> alt.sigConstructor == tag) alts of
    Nothing -> false
    Just { sigValues } ->
      and $ zipWith
        (\sig spine -> isValidSpine (force sig) (force spine))
        sigValues
        values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith
    (\sig val -> isValidSpine (force sig.recValue) (force val.recValue))
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine SigUnit SUnit = true
isValidSpine _ _ = false

-- ## Generic Functions

-- | This function can be used as the default instance for Show for any
-- | instance of Generic
gShow :: forall a. Generic a => a -> String
gShow = genericShowPrec 0 <<< toSpine

genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr)
  | null arr = s
  | otherwise =
      showParen (d > 10) $
        s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (force x)) arr)
      where
      showParen false x = x
      showParen true  x = "(" <> x <> ")"
genericShowPrec _ (SRecord xs) =
  "{" <> joinWith ", " (map showLabelPart xs) <> "}"
  where
  showLabelPart x = x.recLabel <> ": " <> genericShowPrec 0 (force x.recValue)
genericShowPrec _ (SBoolean x) = show x
genericShowPrec _ (SInt x) = show x
genericShowPrec _ (SNumber x) = show x
genericShowPrec _ (SString x) = show x
genericShowPrec _ (SChar x) = show x
genericShowPrec _ (SArray xs) =
  "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (force x)) xs) <> "]"
genericShowPrec _ SUnit = "unit"

-- | This function can be used as an implementation of the `eq` function of `Eq`
-- | for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Eq` instances
-- | rather than relying on `gEq`, where possible.
gEq :: forall a. Generic a => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

-- | This function can be used as an implementation of the `compare` function
-- | of `Ord` for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Ord` instances
-- | rather than relying on `gCompare`, where possible.
gCompare :: forall a. Generic a => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)

-- ## Internal functions

foreign import zipAll
  :: forall a b
   . (a -> b -> Boolean)
  -> Array a
  -> Array b
  -> Boolean

foreign import zipCompare
  :: forall a b
   . (a -> b -> Int)
  -> Array a
  -> Array b
  -> Int

force :: forall a. (Unit -> a) -> a
force f = f unit

compareThunk :: forall a. Ord a => (Unit -> a) -> (Unit -> a) -> Int
compareThunk x y = orderingToInt $ compare (force x) (force y)

eqThunk :: forall a. Eq a => (Unit -> a) -> (Unit -> a) -> Boolean
eqThunk x y = force x == force y

eqRecordSigs
  :: forall a
   . Eq a
  => Array {recLabel :: String, recValue :: Unit -> a}
  -> Array {recLabel :: String, recValue :: Unit -> a}
  -> Boolean
eqRecordSigs arr1 arr2 =
  length arr1 == length arr2 && zipAll doCmp sorted1 sorted2
  where
  labelCompare r1 r2 = compare r1.recLabel r2.recLabel
  sorted1 = sortBy labelCompare arr1
  sorted2 = sortBy labelCompare arr2
  doCmp x y = x.recLabel == y.recLabel && force x.recValue == force y.recValue

orderingToInt :: Ordering -> Int
orderingToInt = case _ of
  EQ -> 0
  LT -> 1
  GT -> -1


trivial Lazy instance for Unit (#40)

trivial Lazy instance for Unit (#40)

module Control.Lazy where

import Data.Unit (Unit, unit)

-- | The `Lazy` class represents types which allow evaluation of values
-- | to be _deferred_.
-- |
-- | Usually, this means that a type contains a function arrow which can
-- | be used to delay evaluation.
class Lazy l where
  defer :: (Unit -> l) -> l

instance lazyFn :: Lazy (a -> b) where
  defer f = \x -> f unit x

instance lazyUnit :: Lazy Unit where
  defer _ = unit

-- | `fix` defines a value as the fixed point of a function.
-- |
-- | The `Lazy` instance allows us to generate the result lazily.
fix :: forall l. Lazy l => (l -> l) -> l
fix f = defer (\_ -> f (fix f))

module Control.Lazy where

import Data.Unit (Unit, unit)

-- | The `Lazy` class represents types which allow evaluation of values
-- | to be _deferred_.
-- |
-- | Usually, this means that a type contains a function arrow which can
-- | be used to delay evaluation.
class Lazy l where
  defer :: (Unit -> l) -> l

instance lazyFn :: Lazy (a -> b) where
  defer f = \x -> f unit x

-- | `fix` defines a value as the fixed point of a function.
-- |
-- | The `Lazy` instance allows us to generate the result lazily.
fix :: forall l. Lazy l => (l -> l) -> l
fix f = defer (\_ -> f (fix f))


Remove consecutive terms restriction

Remove consecutive terms restriction

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty, values, keys)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower, indexOf, joinWith)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat, group)
import Data.Foldable (foldl, all)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data IndexedWord = IndexedWord { word:: Word, pos:: Pos, line:: LineNumber }

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [String] -> PartialTermIndex
createPartialTermIndex = createPartialTermIndex' <<< (<$>) toCharArray
  where
    createPartialTermIndex' []  = D empty
    createPartialTermIndex' ws  =
        foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex' ((<$>) (drop 1) ws'))) m) (D empty) <<<
        (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
        groupBy ((==) `on` head) <<<
        sortBy (compare `on` head) <<<
        filter (not <<< null) $ ws

searchTermsFromPartial :: [Char] -> PartialTermIndex -> Tuple Boolean [[Char]]
searchTermsFromPartial s d = findTerms s d
  where
    flattenValues = (<$>) (s ++) <<< concatMap fst <<< values

    findTerms [] (D d') = Tuple true (flattenValues d')
    findTerms (x:xs) (D d') =
      case lookup x d' of
            Just (Tuple _ d'') -> findTerms xs d''
            Nothing -> Tuple false (flattenValues d')

createIndex :: Doc -> Tuple Index PartialTermIndex
createIndex doc = Tuple index (createPartialTermIndex (keys index))
  where index = createTermIndex doc

getWordIndex :: Tuple Index PartialTermIndex -> String -> [Tuple Pos LineNumber]
getWordIndex (Tuple i pti) w = fromMaybe partialResults
                                    ((++partialResults) <$> lookup w i)
              where matches = searchTermsFromPartial (toCharArray w) pti
                    partialResults = if fst matches then concatMap (\m -> fromJust (lookup m i)) (fromCharArray <$> (snd matches))
                                                    else []

pos :: IndexedWord -> Pos
pos (IndexedWord { word:w, pos:p, line:l }) = p

line :: IndexedWord -> LineNumber
line (IndexedWord { word:w, pos:p, line:l }) = l

word :: IndexedWord -> Word
word (IndexedWord { word:w, pos:p, line:l }) = w

getIndexedWords :: Tuple Index PartialTermIndex -> [Word] -> [IndexedWord]
getIndexedWords i = concatMap (\w -> (<$>) (\(Tuple p l) -> IndexedWord{word:w,pos:p,line:l}) (getWordIndex i w))

groupByLine :: [IndexedWord] -> [[IndexedWord]]
groupByLine = (<$>) (sortBy(compare `on` pos)) <<<
              groupBy ((==) `on` line) <<<
              sortBy(compare `on` line)

equalTermsAndResults :: [Word] -> [IndexedWord] -> Boolean
equalTermsAndResults ws rs = (length ws) <= (length ws') && ((indexOf (joinWith "," (sort ws)) (joinWith "," (sort ws'))) > -1)
        where ws' = word <$> rs

toTuple :: IndexedWord -> Tuple Word (Tuple Pos LineNumber)
toTuple iw = Tuple (word iw) (Tuple (pos iw) (line iw))

search :: Tuple Index PartialTermIndex -> String -> [Tuple Word (Tuple Pos LineNumber)]
search i s = toTuple <$> (concat (filter predicate (groupByLine plwords)))
      where
            predicate = equalTermsAndResults cleaned_words
            cleaned_words = (cleanWords <<< words) s
            plwords = getIndexedWords i cleaned_words

searchLineNumbers :: Tuple Index PartialTermIndex -> String -> [LineNumber]
searchLineNumbers i s =  head <$> (group (sort ((snd <<< snd) <$> (search i s))))

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty, values, keys)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower, indexOf, joinWith)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat, group)
import Data.Foldable (foldl, all)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data IndexedWord = IndexedWord { word:: Word, pos:: Pos, line:: LineNumber }

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [String] -> PartialTermIndex
createPartialTermIndex = createPartialTermIndex' <<< (<$>) toCharArray
  where
    createPartialTermIndex' []  = D empty
    createPartialTermIndex' ws  =
        foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex' ((<$>) (drop 1) ws'))) m) (D empty) <<<
        (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
        groupBy ((==) `on` head) <<<
        sortBy (compare `on` head) <<<
        filter (not <<< null) $ ws

searchTermsFromPartial :: [Char] -> PartialTermIndex -> Tuple Boolean [[Char]]
searchTermsFromPartial s d = findTerms s d
  where
    flattenValues = (<$>) (s ++) <<< concatMap fst <<< values

    findTerms [] (D d') = Tuple true (flattenValues d')
    findTerms (x:xs) (D d') =
      case lookup x d' of
            Just (Tuple _ d'') -> findTerms xs d''
            Nothing -> Tuple false (flattenValues d')

createIndex :: Doc -> Tuple Index PartialTermIndex
createIndex doc = Tuple index (createPartialTermIndex (keys index))
  where index = createTermIndex doc

getWordIndex :: Tuple Index PartialTermIndex -> String -> [Tuple Pos LineNumber]
getWordIndex (Tuple i pti) w = fromMaybe partialResults
                                    ((++partialResults) <$> lookup w i)
              where matches = searchTermsFromPartial (toCharArray w) pti
                    partialResults = if fst matches then concatMap (\m -> fromJust (lookup m i)) (fromCharArray <$> (snd matches))
                                                    else []

pos :: IndexedWord -> Pos
pos (IndexedWord { word:w, pos:p, line:l }) = p

line :: IndexedWord -> LineNumber
line (IndexedWord { word:w, pos:p, line:l }) = l

word :: IndexedWord -> Word
word (IndexedWord { word:w, pos:p, line:l }) = w

getIndexedWords :: Tuple Index PartialTermIndex -> [Word] -> [IndexedWord]
getIndexedWords i = concatMap (\w -> (<$>) (\(Tuple p l) -> IndexedWord{word:w,pos:p,line:l}) (getWordIndex i w))

groupByLine :: [IndexedWord] -> [[IndexedWord]]
groupByLine = (<$>) (sortBy(compare `on` pos)) <<<
              groupBy ((==) `on` line) <<<
              sortBy(compare `on` line)

equalTermsAndResults :: [Word] -> [IndexedWord] -> Boolean
equalTermsAndResults ws rs = (length ws) <= (length ws') && ((indexOf (joinWith "," (sort ws)) (joinWith "," (sort ws'))) > -1)
        where ws' = word <$> rs

consecutiveWords :: [IndexedWord] -> Boolean
consecutiveWords rs = all (\(Tuple x y) -> y - x <= 2) (zip ps (drop 1 ps))
              where ps = pos <$> rs

toTuple :: IndexedWord -> Tuple Word (Tuple Pos LineNumber)
toTuple iw = Tuple (word iw) (Tuple (pos iw) (line iw))

search :: Tuple Index PartialTermIndex -> String -> [Tuple Word (Tuple Pos LineNumber)]
search i s = toTuple <$> (concat (filter predicate (groupByLine plwords)))
      where
            predicate = both (equalTermsAndResults cleaned_words) consecutiveWords
            cleaned_words = (cleanWords <<< words) s
            plwords = getIndexedWords i cleaned_words

searchLineNumbers :: Tuple Index PartialTermIndex -> String -> [LineNumber]
searchLineNumbers i s =  head <$> (group (sort ((snd <<< snd) <$> (search i s))))


axes added but no longer compiling

axes added but no longer compiling

module Main where

import D3.Axis
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import D3.Base (PolyValue(Value), AttrSetter(SetAttr, AttrFn), DataBind(Data), D3, (..), (...))
import D3.Collections (D3Collection(D3Range, D3ArrT))
import D3.Scale (ScaleType(Linear, Band), scaleBy, bandwidth, domain, rangeRound, d3Scale, padding)
import D3.Selection (attr, append, enter, dataBind, selectAll, text, getAttr, d3Select)
import Data.Maybe (Maybe(Just))
import Prelude (map, Unit, unit, pure, bind, show, (-), (<>), ($), (>>=), (=<<))

type Pair = { letter :: Char, frequency :: Number }
frequencies :: Array Pair
frequencies = [
    { letter: 'A',	frequency: 0.08167 }
  , { letter: 'B',	frequency: 0.01492 }
  , { letter: 'C',	frequency: 0.02782 }
  , { letter: 'D',	frequency: 0.04253 }
  , { letter: 'E',	frequency: 0.12702 }
  , { letter: 'F',	frequency: 0.02288 }
  , { letter: 'G',	frequency: 0.02015 }
  , { letter: 'H',	frequency: 0.06094 }
  , { letter: 'I',	frequency: 0.06966 }
  , { letter: 'J',	frequency: 0.00153 }
  , { letter: 'K',	frequency: 0.00772 }
  , { letter: 'L',	frequency: 0.04025 }
  , { letter: 'M',	frequency: 0.02406 }
  , { letter: 'N',	frequency: 0.06749 }
  , { letter: 'O',	frequency: 0.07507 }
  , { letter: 'P',	frequency: 0.01929 }
  , { letter: 'Q',	frequency: 0.00095 }
  , { letter: 'R',	frequency: 0.05987 }
  , { letter: 'S',	frequency: 0.06327 }
  , { letter: 'T',	frequency: 0.09056 }
  , { letter: 'U',	frequency: 0.02758 }
  , { letter: 'V',	frequency: 0.00978 }
  , { letter: 'W',	frequency: 0.02360 }
  , { letter: 'X',	frequency: 0.00150 }
  , { letter: 'Y',	frequency: 0.01974 }
  , { letter: 'Z',	frequency: 0.00074 }
]

-- define a margin, look to purescript-css for more sophisticated definition
margin :: { top::Number, right::Number, bottom::Number, left::Number }
margin = { top: 20.0, right: 20.0, bottom: 30.0, left: 40.0}

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  svg <- d3Select ".svg"

  w <- svg ... getAttr "width"
  h <- svg ... getAttr "height"
  let width =  w - margin.left - margin.right
  let height = h - margin.top - margin.bottom

  x <- d3Scale Band
        .. rangeRound 0.0 width
        .. padding 0.1
        .. domain (D3ArrT (map (\d -> d.letter) frequencies))

  xaxis <- d3AxisBottom x

  y <- d3Scale Linear
        .. rangeRound height 0.0
        .. domain (D3Range 0.0 0.12702) -- implement max lookup later TODO

  yaxis <- d3AxisLeft y
        .. axisTicks (Count 10.0 (Just "%"))

  g <-  svg ... append "g"
    ..  attr "transform"  (SetAttr ("translate(" <> show margin.left <> "," <> show margin.top <> ")"))

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--x")
    ..  attr "transform"  (SetAttr ("translate(0," <> show height <> ")"))
    ..  renderAxis xaxis

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--y")

  g  ... append "text"
    .. renderAxis yaxis
    .. attr "transform"   (SetAttr "rotate(-90)")
    .. attr "y"           (SetAttr 6.0)
    .. attr "dy"          (SetAttr "0.71em")
    .. attr "text-anchor" (SetAttr "end")
    .. text (Value "Frequency")

  g  ... selectAll (".bar")
      .. dataBind (Data frequencies)
    .. enter .. append "rect"
      .. attr "class"  (SetAttr "bar")
      .. attr "x"      (AttrFn (\d i nodes el -> scaleBy x d.letter))
      .. attr "y"      (AttrFn (\d i nodes el -> scaleBy y d.frequency))
      .. attr "width"  (SetAttr (bandwidth x))
      .. attr "height" (AttrFn (\d i nodes el -> do scaled <- scaleBy y d.frequency
                                                    pure (height - scaled)))
  pure unit

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import D3.Base (PolyValue(Value), AttrSetter(SetAttr, AttrFn), DataBind(Data), D3, (..), (...))
import D3.Collections (D3Collection(D3Range, D3ArrT))

import D3.Scale (ScaleType(Linear, Band), scaleBy, bandwidth, domain, rangeRound, d3Scale, padding)
import D3.Selection (attr, append, enter, dataBind, selectAll, text, getAttr, d3Select)
import Prelude (map, Unit, unit, pure, bind, show, (-), (<>), ($), (>>=), (=<<))

type Pair = { letter :: Char, frequency :: Number }
frequencies :: Array Pair
frequencies = [
    { letter: 'A',	frequency: 0.08167 }
  , { letter: 'B',	frequency: 0.01492 }
  , { letter: 'C',	frequency: 0.02782 }
  , { letter: 'D',	frequency: 0.04253 }
  , { letter: 'E',	frequency: 0.12702 }
  , { letter: 'F',	frequency: 0.02288 }
  , { letter: 'G',	frequency: 0.02015 }
  , { letter: 'H',	frequency: 0.06094 }
  , { letter: 'I',	frequency: 0.06966 }
  , { letter: 'J',	frequency: 0.00153 }
  , { letter: 'K',	frequency: 0.00772 }
  , { letter: 'L',	frequency: 0.04025 }
  , { letter: 'M',	frequency: 0.02406 }
  , { letter: 'N',	frequency: 0.06749 }
  , { letter: 'O',	frequency: 0.07507 }
  , { letter: 'P',	frequency: 0.01929 }
  , { letter: 'Q',	frequency: 0.00095 }
  , { letter: 'R',	frequency: 0.05987 }
  , { letter: 'S',	frequency: 0.06327 }
  , { letter: 'T',	frequency: 0.09056 }
  , { letter: 'U',	frequency: 0.02758 }
  , { letter: 'V',	frequency: 0.00978 }
  , { letter: 'W',	frequency: 0.02360 }
  , { letter: 'X',	frequency: 0.00150 }
  , { letter: 'Y',	frequency: 0.01974 }
  , { letter: 'Z',	frequency: 0.00074 }
]

-- define a margin, look to purescript-css for more sophisticated definition
margin :: { top::Number, right::Number, bottom::Number, left::Number }
margin = { top: 20.0, right: 20.0, bottom: 30.0, left: 40.0}

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  svg <- d3Select ".svg"

  w <- svg ... getAttr "width"
  h <- svg ... getAttr "height"
  let width =  w - margin.left - margin.right
  let height = h - margin.top - margin.bottom

  x <- d3Scale Band
        .. rangeRound 0.0 width
        .. padding 0.1
        .. domain (D3ArrT (map (\d -> d.letter) frequencies))

  y <- d3Scale Linear
        .. rangeRound height 0.0
        .. domain (D3Range 0.0 0.12702) -- implement max lookup later TODO

  g <-  svg ... append "g"
    ..  attr "transform"  (SetAttr ("translate(" <> show margin.left <> "," <> show margin.top <> ")"))

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--x")
    ..  attr "transform"  (SetAttr ("translate(0," <> show height <> ")"))
    -- ..  call d3AxisBottom x

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--y")
    -- ..  call d3AxisLeft y .. ticks 10 '%'
    .. append "text"
    .. attr "transform"   (SetAttr "rotate(-90)")
    .. attr "y"           (SetAttr 6.0)
    .. attr "dy"          (SetAttr "0.71em")
    .. attr "text-anchor" (SetAttr "end")
    .. text (Value "Frequency")

  g  ... selectAll (".bar")
      .. dataBind (Data frequencies)
    .. enter .. append "rect"
      .. attr "class"  (SetAttr "bar")
      .. attr "x"      (AttrFn (\d i nodes el -> scaleBy x d.letter))
      .. attr "y"      (AttrFn (\d i nodes el -> scaleBy y d.frequency))
      .. attr "width"  (SetAttr (bandwidth x))
      .. attr "height" (AttrFn (\d i nodes el -> do scaled <- scaleBy y d.frequency
                                                    pure (height - scaled)))
  pure unit