added exports

added exports

module Control.Monad.Eff.Redux
                  (
                      ReduxM
                    , Redux
                    , ReduxEff
                    , Reducer
                    , Dispatch
                    , GetState
                    , CreateStore
                    , Next
                    , Middleware
                    , Store
                    , Action
                    , createStore
                    , subscribe
                    , dispatch
                    , getState
                    , replaceReducer
                    , combineReducers
                    , applyMiddleware
                  )
                  where

import Prelude              (Unit)
import Control.Monad.Eff    (Eff)
import Data.Foreign.EasyFFI (unsafeForeignFunction, unsafeForeignProcedure)

-- | Redux Objects & Effects

-- `action object` for the `dispatch`-API of `createStore`
-- according to Redux docs the action objects must have a `type` property
-- it is recommended to use string constants for `type`
type Action a b = {
  "type" :: a
  | b
}

foreign import data ReduxM :: !

foreign import data Redux  :: *

foreign import data Store  :: *

type ReduxEff a  = forall e. Eff (reduxM :: ReduxM | e) a

type Reducer     = forall a b c. a -> Action b c -> a

type Dispatch    = forall a b. Action a b -> ReduxEff (Action a b)

type GetState    = forall a. ReduxEff a

type CreateStore = forall a. Reducer -> a -> ReduxEff Store

type Next        = Dispatch

type Middleware  = forall a b. Store -> Next -> (Action a b) -> ReduxEff (Action a b)

-- | FFI Calls / Shortcuts
ffiF :: forall a. Array String -> String -> a
ffiF = unsafeForeignFunction

ffiP :: forall a. Array String -> String -> a
ffiP = unsafeForeignProcedure

-- | **TODO** Redux APIs (http://redux.js.org/)
foreign import createStore      :: forall a b c. (a -> Action b c -> a) -> a -> ReduxEff Store

foreign import subscribe        :: forall e. (Eff e Unit) -> Store -> ReduxEff Unit

foreign import dispatch         :: forall a b. Action a b -> Store -> ReduxEff (Action a b)

foreign import getState         :: forall a. Store -> ReduxEff a

foreign import replaceReducer   :: Reducer -> Store -> ReduxEff Unit

foreign import combineReducers  :: forall a b c. Array (a -> Action b c -> a) -> ReduxEff Reducer

foreign import applyMiddleware  :: forall a b c d. Array a -> (b -> Action c d -> b) -> b -> ReduxEff Store

module Control.Monad.Eff.Redux where

import Prelude              (Unit)
import Control.Monad.Eff    (Eff)
import Data.Foreign.EasyFFI (unsafeForeignFunction, unsafeForeignProcedure)

-- | Redux Objects & Effects

-- `action object` for the `dispatch`-API of `createStore`
-- according to Redux docs the action objects must have a `type` property
-- it is recommended to use string constants for `type`
type Action a b = {
  "type" :: a
  | b
}

foreign import data ReduxM :: !

foreign import data Redux  :: *

foreign import data Store  :: *

type ReduxEff a  = forall e. Eff (reduxM :: ReduxM | e) a

type Reducer     = forall a b c. a -> Action b c -> a

type Dispatch    = forall a b. Action a b -> ReduxEff (Action a b)

type GetState    = forall a. ReduxEff a

type CreateStore = forall a. Reducer -> a -> ReduxEff Store

type Next        = Dispatch

type Middleware  = forall a b. Store -> Next -> (Action a b) -> ReduxEff (Action a b)

-- | FFI Calls / Shortcuts
ffiF :: forall a. Array String -> String -> a
ffiF = unsafeForeignFunction

ffiP :: forall a. Array String -> String -> a
ffiP = unsafeForeignProcedure

-- | **TODO** Redux APIs (http://redux.js.org/)
foreign import createStore      :: forall a b c. (a -> Action b c -> a) -> a -> ReduxEff Store

foreign import subscribe        :: forall e. (Eff e Unit) -> Store -> ReduxEff Unit

foreign import dispatch         :: forall a b. Action a b -> Store -> ReduxEff (Action a b)

foreign import getState         :: forall a. Store -> ReduxEff a

foreign import replaceReducer   :: Reducer -> Store -> ReduxEff Unit

foreign import combineReducers  :: forall a b c. Array (a -> Action b c -> a) -> ReduxEff Reducer

foreign import applyMiddleware  :: forall a b c d. Array a -> (b -> Action c d -> b) -> b -> ReduxEff Store


calculate actual cost

calculate actual cost

module KanColle.Expedition.New.Types
  ( module KanColle.Expedition.New.SType
  , module KanColle.Expedition.New.Item
  , FleetCompo
  , MinFleetCompo
  , FleetMaxCost
  , Info
  , ItemInfo
  , MaxCost(..)
  , mkMC
  , CostModel
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import KanColle.Expedition.New.Item
import Data.Map as M
import Data.Tuple
import Data.Traversable
import Data.Int

-- Nothing: ship type not specified
-- Just <stype>: must be of ship type <stype>
type MinFleetCompo = Array (Maybe SType)
type FleetCompo = Array SType
type FleetMaxCost = Array MaxCost

type Info =
  { id :: Int
  , timeInMin :: Int
  , fuelCostPercent :: Number
  , ammoCostPercent :: Number
  , item1 :: Maybe ItemInfo
  , item2 :: Maybe ItemInfo
  }

type ItemInfo =
  { item :: Item
  , maxCount :: Int
  }

newtype MaxCost = MCost
  { fuel :: Int
  , ammo :: Int
  }

newtype ActualCost = ACost
  { fuel :: Int
  , ammo :: Int
  }

mkMC :: Int -> Int -> MaxCost
mkMC fuel ammo = MCost {fuel: fuel, ammo: ammo}

-- | `CostModel` calculates the total maximum cost
-- | given a ship type and how many ships are present.
-- | This cost model is designed for just one fleet so
-- | the input number should only be one of `[0,1,2,3,4,5,6]`.
-- | Note that for a cost model `f`, it's not guaranteed
-- | that `f stype a + f stype b` and `f stype (a+b)` give
-- | the same answer.
type CostModel = SType -> Int -> Maybe (Array MaxCost)

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)

calcActualCost :: MaxCost -> Info -> ActualCost
calcActualCost (MCost mc) info = ACost
    { fuel: floor (info.fuelCostPercent * toNumber mc.fuel)
    , ammo: floor (info.ammoCostPercent * toNumber mc.ammo)
    }

module KanColle.Expedition.New.Types
  ( module KanColle.Expedition.New.SType
  , module KanColle.Expedition.New.Item
  , FleetCompo
  , MinFleetCompo
  , FleetMaxCost
  , Info
  , ItemInfo
  , MaxCost(..)
  , mkMC
  , CostModel
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import KanColle.Expedition.New.Item
import Data.Map as M
import Data.Tuple
import Data.Traversable

-- Nothing: ship type not specified
-- Just <stype>: must be of ship type <stype>
type MinFleetCompo = Array (Maybe SType)
type FleetCompo = Array SType
type FleetMaxCost = Array MaxCost

type Info =
  { id :: Int
  , timeInMin :: Int
  , fuelCostPercent :: Number
  , ammoCostPercent :: Number
  , item1 :: Maybe ItemInfo
  , item2 :: Maybe ItemInfo
  }

type ItemInfo =
  { item :: Item
  , maxCount :: Int
  }

newtype MaxCost = MC
  { fuel :: Int
  , ammo :: Int
  }

mkMC :: Int -> Int -> MaxCost
mkMC fuel ammo = MC {fuel: fuel, ammo: ammo}

-- | `CostModel` calculates the total maximum cost
-- | given a ship type and how many ships are present.
-- | This cost model is designed for just one fleet so
-- | the input number should only be one of `[0,1,2,3,4,5,6]`.
-- | Note that for a cost model `f`, it's not guaranteed
-- | that `f stype a + f stype b` and `f stype (a+b)` give
-- | the same answer.
type CostModel = SType -> Int -> Maybe (Array MaxCost)

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)


Spliceable typeclass, generalization, remove Diff1

module Types where

import Prelude

import Control.Apply (lift2)
import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
import Control.Monad.State (State, gets, modify, runState)
import Data.Array (concatMap, last, uncons, unsnoc)
import Data.Array (fromFoldable, length, take, drop) as Array
import Data.Bifunctor (lmap)
import Data.Const (Const(..))
import Data.Either (Either)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Mu (Mu, roll, unroll)
import Data.Functor.Product (Product(..))
import Data.Functor.Variant (FProxy, SProxy(..), VariantF)
import Data.Functor.Variant as VF
import Data.Map (Map)
import Data.Map (fromFoldable, toAscUnfoldable, singleton, insert) as Map
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (over2, unwrap)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Pair (Pair(..))
import Data.Set (Set)
import Data.Set (toUnfoldable) as Set
import Data.StrMap (StrMap)
import Data.StrMap (toUnfoldable) as StrMap
import Data.String (Pattern(..), Replacement(..), joinWith, replaceAll)
import Data.String (drop, take, length) as String
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..), fst, snd, swap, uncurry)
import Matryoshka (class Recursive, Algebra, cata, project)

onlyType :: Proper -> Import
onlyType = Type <@> mempty
dataModule :: Array Proper -> Module
dataModule rest = Module (Proper "Data" :| rest)
dataImport :: Proper -> Tuple Module ImportModule
dataImport name =
  pure (Type name mempty) `importFrom`
    dataModule (pure name)
importAll :: ImportModule
importAll = ImportModule (pure mempty) mempty
importAllFrom :: Module -> Tuple Module ImportModule
importAllFrom = Tuple <@> importAll
importFrom :: Imports -> Module -> Tuple Module ImportModule
importFrom is = Tuple <@> ImportModule (pure is) mempty

aType :: ATypeVF ATypeV -> ATypeV
aType = roll

aTypeConst ::
  forall sym a bleh.
    IsSymbol sym =>
    RowCons sym (FProxy (Const a)) bleh ATypeVR =>
  SProxy sym -> a -> ATypeV
aTypeConst k a = aType $ VF.inj k $ Const a

aTypePair ::
  forall sym bleh.
    IsSymbol sym =>
    RowCons sym (FProxy Pair) bleh ATypeVR =>
  SProxy sym -> ATypeV -> ATypeV -> ATypeV
aTypePair k a b  = aType $ VF.inj k $ Pair a b

aTypeProduct ::
  forall sym f g bleh.
    IsSymbol sym =>
    Functor f =>
    Functor g =>
    RowCons sym (FProxy (Product f g)) bleh ATypeVR =>
  SProxy sym -> f ATypeV -> g ATypeV -> ATypeV
aTypeProduct k a b = aType $ VF.inj k $ Product $ Tuple a b

aTypeApp :: ATypeV -> ATypeV -> ATypeV
aTypeApp = aTypePair _app

aTypeFunction :: ATypeV -> ATypeV -> ATypeV
aTypeFunction = aTypePair _function

aTypeName :: Qualified Proper -> ATypeV
aTypeName = aTypeConst _name

aTypeVar :: Ident -> ATypeV
aTypeVar = aTypeConst _var

typeAbsType :: Ident -> TypeAbs
typeAbsType = TypeAbs <@> Nothing

newType :: Proper -> ATypeV -> DataTypeDef
newType name typ = DataTypeDef mempty $ SumType $ Map.singleton name $ pure typ

namedNewType :: Proper -> ATypeV -> Tuple Proper DataTypeDef
namedNewType = lift2 compose Tuple newType

alias :: Proper -> NonEmpty Array (Qualified Proper) -> Tuple Proper DataTypeDef
alias name as = Tuple name $ DataTypeDef mempty $ TypeAlias (chainl aTypeApp as)

chainl :: (ATypeV -> ATypeV -> ATypeV) -> NonEmpty Array (Qualified Proper) -> ATypeV
chainl app (fn :| args) = go (aTypeName fn) args
  where
    go :: ATypeV -> Array (Qualified Proper) -> ATypeV
    go f as = case uncons as of
      Nothing -> f
      Just { head, tail } ->
        go (app f (aTypeName head)) tail

chainr :: (ATypeV -> ATypeV -> ATypeV) -> NonEmpty Array (Qualified Proper) -> ATypeV
chainr app (fn :| args) = go (aTypeName fn) args
  where
    go :: ATypeV -> Array (Qualified Proper) -> ATypeV
    go f as = case unsnoc as of
      Nothing -> f
      Just { init, last } ->
        go (app (aTypeName last) f) init

qualifyP :: Proper -> Qualified Proper
qualifyP p@(Proper name) = case name of
  "NonEmpty" -> qualifyData p
  "Either" -> qualifyData p
  "Map" -> qualifyData p
  "String" -> prim p
  _ -> Unqualified p

qualifyData :: Proper -> Qualified Proper
qualifyData p = Qualified (dataModule $ pure p) p

prim :: Proper -> Qualified Proper
prim = Qualified (Module (Proper "Prim" :| mempty))

qualify :: Tuple Module ImportModule -> Imports -> Tuple Module ImportModule
qualify (Tuple name (ImportModule mims mp)) is =
  Tuple name (ImportModule mims mp')
  where
    mp' = Map.insert (Module (lastOf name :| [])) is mp

thisModule :: ModuleData
thisModule =
  { imports: Map.fromFoldable
    [ importAllFrom $ Module $ Proper <$> "Prelude" :| mempty
    , dataImport $ Proper "Either"
    , [onlyType $ Proper "Mu"] `importFrom`
      (dataModule $ Proper <$> ["Functor", "Mu"])
    , dataImport (Proper "Map") `qualify`
        (Value <<< Ident <$> ["fromFoldable", "toAscUnfoldable", "singleton", "insert"])
    , dataImport $ Proper "Maybe"
    , [Class $ Proper "Monoid", Value $ Ident "mempty"] `importFrom`
      (dataModule $ pure $ Proper "Monoid")
    , dataImport (Proper "NonEmpty") <#> flip append
        (ImportModule (pure (pure (Operator (Op ":|")))) mempty)
    , dataImport $ Proper "Set"
    , dataImport $ Proper "StrMap"
    , [Type (Proper "Tuple") (pure AllCs)] `importFrom`
      (dataModule $ pure $ Proper "Tuple")
    ]
  , datatypes: Map.fromFoldable
    [ Proper "Module" `namedNewType`
        chainl aTypeApp (Unqualified <<< Proper <$> "NonEmpty" :| ["Array", "Proper"])
    , Tuple (Proper "Qualified") $ DataTypeDef [typeAbsType $ Ident "a"] $
        SumType $ Map.fromFoldable
        [ Tuple (Proper "Qualified")
          [ atnunqp "Module"
          , aTypeVar $ Ident "a"
          ]
        , Tuple (Proper "Unqualified") $ pure $ aTypeVar $ Ident "a"
        ]
    , Proper "Proper" `namedNewType` aTypeName (Unqualified $ Proper "String")
    , Proper "Ident" `namedNewType` aTypeName (Unqualified $ Proper "String")
    , Proper "Op" `namedNewType` aTypeName (Unqualified $ Proper "String")
    , Proper "ProperOp" `alias`
      ( Unqualified <<< Proper <$> "Either" :| ["Proper", "Op"] )
    , Proper "IdentOp" `alias`
      ( Unqualified <<< Proper <$> "Either" :| ["Ident", "Op"] )
    , Proper "ImportModules" `alias`
      ( Unqualified <<< Proper <$> "Map" :| ["Module", "ImportModule"] )
    , Tuple (Proper "ImportModule") $ DataTypeDef mempty $
        SumType $ Map.singleton (Proper "ImportModule") $
        [ aTypeApp (atnunqp "Maybe") $ atnunqp "Imports"
        , chainl aTypeApp (Unqualified <<< Proper <$> "Map" :| ["Module", "Imports"])
        ]
    , Tuple (Proper "FUNCTION") $ DataTypeDef mempty $
        TypeAlias $
          testType
    ]
  }

atnunqp :: String -> ATypeV
atnunqp = aTypeName <<< Unqualified <<< Proper

testType :: ATypeV
testType = chainl aTypeFunction (Unqualified <<< Proper <$> "Module" :| ["Imports", "ImportModule"])
  `aTypeFunction` ((atnunqp "Map" `aTypeApp` (atnunqp "Maybe" `aTypeApp` atnunqp "Module"))
    `aTypeApp` (atnunqp "Meh" `aTypeFunction` atnunqp "Eh"))

otherTest :: ATypeV
otherTest = chainr aTypeFunction (Unqualified <<< Proper <$> "Heus" :| ["Yo", "Hey"])

testTypeL :: Tuple (Maybe (ZipperVF ATypeV Unit)) ATypeV
testTypeL = extract1 left testType

testTypeLS :: String
testTypeLS = case testTypeL of
  Tuple (Just z) h ->
    "(" <> simpleShowZ1 showAType z <> ", " <> showAType h <> ")"
  Tuple Nothing h -> showAType h

testTypeC :: Tuple String ATypeVC
testTypeC = case showTagged testType of
  Tuple s v -> Tuple s $ Tuple mempty (length s) :< v

testTypeCS :: String
testTypeCS = cofrecurse (snd testTypeC)

testTypeLC :: Tuple (Maybe (ZipperVF ATypeVC Tag)) ATypeVC
testTypeLC = extract1C rightC (snd testTypeC)

testTypeLC' :: Tuple ZipperVC ATypeVC
testTypeLC' = extract1C' rightC (snd testTypeC)

testTypeLSC :: String
testTypeLSC = case testTypeLC of
  Tuple (Just z) h ->
    "(" <> simpleShowZ1 (forget >>> showAType) z <> ", " <> showAType (forget h) <> ")"
  Tuple Nothing h -> showAType (forget h)

testPatchSameR :: Tuple String ATypeVC
testPatchSameR = uncurry patch (map forget testTypeLC') (fst testTypeC) mempty Nothing

testPatchSameL :: Tuple String ATypeVC
testPatchSameL = uncurry patch (map forget $ extract1C' leftC (snd testTypeC)) (fst testTypeC) mempty Nothing

testPatchExplodeR :: Tuple String ATypeVC
testPatchExplodeR = patch (fst testTypeLC') otherTest (fst testTypeC) mempty Nothing

testPatchExplodeL :: Tuple String ATypeVC
testPatchExplodeL = patch (fst $ extract1C' leftC (snd testTypeC)) otherTest (fst testTypeC) mempty Nothing

forget :: forall f a. Functor f => Cofree f a -> Mu f
forget v = tail v # map forget # roll

badindent :: String -> String
badindent = replaceAll (Pattern "\n") (Replacement "\n  ")

cofrecurse :: ATypeVC -> String
cofrecurse v = let t = " >: " <> show (head v) in
  ( VF.case_
  # VF.on _var (unwrap >>> show >>> (_ <> t))
  # VF.on _name (unwrap >>> show >>> (_ <> t))
  # VF.on _function (\(Pair l r) -> "function" <> t <>
      badindent ("\n" <> cofrecurse l <> "\n" <> cofrecurse r))
  # VF.on _app (\(Pair l r) -> "app" <> t <>
      badindent ("\n" <> cofrecurse l <> "\n" <> cofrecurse r))
  ) (tail v)

newtype Module = Module (NonEmpty Array Proper)
derive newtype instance eqModule :: Eq Module
derive newtype instance ordModule :: Ord Module
instance showModule :: Show Module where
  show (Module (top :| [])) = show top
  show (Module (top :| rest)) =
    show top <> "." <> joinWith "." (show <$> rest)
lastOf :: Module -> Proper
lastOf (Module (n :| ns)) = fromMaybe n $ last ns
data Qualified a
  = Qualified Module a
  | Unqualified a
instance showQualified :: Show a => Show (Qualified a) where
  show (Unqualified a) = show a
  show (Qualified m a) = show m <> "." <> show a
newtype Proper = Proper String
derive newtype instance eqProper :: Eq Proper
derive newtype instance ordProper :: Ord Proper
instance showProper :: Show Proper where
  show (Proper p) = p
newtype Ident = Ident String
derive newtype instance eqIdent :: Eq Ident
derive newtype instance ordIdent :: Ord Ident
instance showIdent :: Show Ident where
  show (Ident p) = p
newtype Op = Op String
derive newtype instance eqOp :: Eq Op
derive newtype instance ordOp :: Ord Op
instance showOp :: Show Op where
  show (Op p) = p
type ProperOp = Either Op Proper
type IdentOp = Either Op Ident

type ImportModules = Map Module ImportModule
data ImportModule =
  ImportModule
    (Maybe Imports)
    (Map Module Imports)
instance semigroupImportModule :: Semigroup ImportModule where
  append (ImportModule is as) (ImportModule iz az) =
    ImportModule (is <> iz) (as <> az)
instance monoidImportModule :: Monoid ImportModule where
  mempty = ImportModule mempty mempty
showImportModules :: ImportModules -> String
showImportModules = joinWith "\n" <<< Map.toAscUnfoldable >>> concatMap
  \(Tuple modul (ImportModule mims aliases)) ->
    let
      showUnq []  = "import " <> show modul
      showUnq ims = "import " <> show modul <> " " <>
        "(" <> joinWith ", " (show <$> ims) <> ")"
      showQ (Tuple mod alias) = showUnq alias <> " as " <> show mod
    in Array.fromFoldable (showUnq <$> mims) <>
      (showQ <$> Map.toAscUnfoldable aliases)

type Imports = Array Import
data Import
  = Value Ident
  | Type Proper (Maybe Constructors)
  | Class Proper
  | Kind Proper
  | Operator Op
  | TypeOperator Op
instance showImport :: Show Import where
  show (Value i) = show i
  show (Type p Nothing) = show p
  show (Type p (Just cs)) = show p <> "(" <> show cs <> ")"
  show (Class p) = "class " <> show p
  show (Kind p) = "kind " <> show p
  show (Operator o) = "(" <> show o <> ")"
  show (TypeOperator o) = "type (" <> show o <> ")"
data Constructors = AllCs | SpecificCs (Set Proper)
instance showConstructors :: Show Constructors where
  show (SpecificCs ps) = joinWith ", " (show <$> Set.toUnfoldable ps)
  show AllCs = ".."
instance semigroupConstructors :: Semigroup Constructors where
  append (SpecificCs a) (SpecificCs b) = SpecificCs (a <> b)
  append _ _ = AllCs
instance monoidConstructors :: Monoid Constructors where
  mempty = SpecificCs mempty

wrap :: String -> String
wrap a = "(" <> a <> ")"

joinWithIfNE :: forall a. String -> (a -> String) -> Array a -> String
joinWithIfNE _ _ [] = ""
joinWithIfNE sep f as = sep <> joinWith sep (f <$> as)

data DataType
  = TypeAlias ATypeV
  | SumType (Map Proper (Array ATypeV))
instance showDataType :: Show DataType where
  show (TypeAlias t) = showAType t
  show (SumType m) = joinWith " | " $ Map.toAscUnfoldable m <#> \(Tuple c ts) ->
    show c <> joinWithIfNE " " (showAType' (Just FnAppParen)) ts
data DeclKeyword = TType | TNewtype | TData
derive instance eqDeclKeyword :: Eq DeclKeyword
derive instance ordDeclKeyword :: Ord DeclKeyword
instance showDeclKeyword :: Show DeclKeyword where
  show TType = "type"
  show TNewtype = "newtype"
  show TData = "data"
declKeyword :: DataType -> DeclKeyword
declKeyword (TypeAlias _) = TType
declKeyword (SumType m)
  | [Tuple _ [_]] <- Map.toAscUnfoldable m
    = TNewtype
  | otherwise
    = TData
type ATypeVR =
  ( name     :: FProxy (Const (Qualified Proper))
  , var      :: FProxy (Const Ident)
  , function :: FProxy Pair
  , app      :: FProxy Pair
  -- , row      :: FProxy (Product StrMap Maybe)
  )
type ATypeVF = VariantF ATypeVR
type ATypeV = Mu ATypeVF
type ATypeVC = Tagged ATypeVF

data DPair' a da = DPairL' da a | DPairR' a da
derive instance functorDPair' :: Functor (DPair' a)
instance showDPair' :: (Show a, Show da) => Show (DPair' a da) where
  show (DPairL' da a) = "(DPairL' " <> show da <> " " <> show a <> ")"
  show (DPairR' a da) = "(DPairR' " <> show a <> " " <> show da <> ")"
data DStrMap' a da = DStrMap' String da (StrMap a)
type DATypeVR' a da =
  ( name     :: Unit
  , var      :: Unit
  , function :: DPair' a da
  , app      :: DPair' a da
  -- , row      :: Tuple (DStrMap' a da) da
  )
data DMu' f df = DIn' (df (Mu f) (DMu' f df)) (DMu' f df)

type ZipperVR a =
  ( function :: FProxy (DPair' a)
  , app :: FProxy (DPair' a)
  )
type ZipperVF a = VariantF (ZipperVR a)
type ZipperVF' a = Compose Maybe (ZipperVF a)
type ZipperVF'' a = Compose Maybe (Compose (Tuple Tag) (ZipperVF a))
type ZipperV = Mu (ZipperVF' ATypeV)
type ZipperVC = Tagged (ZipperVF' ATypeVC)

simpleShowZ :: forall a. (a -> String) -> Algebra (ZipperVF a) String
simpleShowZ inner = VF.match
  { function: showDPair' " -> "
  , app: showDPair' " "
  --, row: const "()"
  }
  where
    showDPair' :: String -> DPair' a String -> String
    showDPair' s (DPairL' da a) = "{" <> da <> "}" <> s <> inner a
    showDPair' s (DPairR' a da) = inner a <> s <> "{" <> da <> "}"

simpleShowZ1 :: forall a s. Show s => (a -> String) -> ZipperVF a s -> String
simpleShowZ1 inner v = simpleShowZ inner (v <#> show)

_name = SProxy :: SProxy "name"
_var = SProxy :: SProxy "var"
_function = SProxy :: SProxy "function"
_app = SProxy :: SProxy "app"

downZipperVF :: forall a da. (a -> da) -> ATypeVF a -> ATypeVF (ZipperVF a da)
downZipperVF down = VF.case_
  # VF.on _name (VF.inj _name <<< rewrap)
  # VF.on _var (VF.inj _var <<< rewrap)
  # VF.on _function (downDPair' down >>> rePair' _function)
  # VF.on _app (downDPair' down >>> rePair' _app)

rePair' ::
  forall a da sym bleh meh.
    IsSymbol sym =>
    RowCons sym (FProxy Pair) bleh ATypeVR =>
    RowCons sym (FProxy (DPair' a)) meh (ZipperVR a) =>
  SProxy sym -> Pair (DPair' a da) -> ATypeVF (ZipperVF a da)
rePair' sym = VF.inj sym <<< map (VF.inj sym)

{-
downZipperVF' :: forall a da. (a -> da) -> ATypeVF a -> ZipperVF' a da
downZipperVF' down = VF.default (Compose Nothing)
    # VF.on _function (downDPair' down >>> map (VF.inj _function) >>> Just >>> Compose)
    # VF.on _app (downDPair' down >>> map (VF.inj _app) >>> Just >>> Compose)
-}

{-
     ATypeV
down (a -> b) =
              ATypeVF ()
              ->
  (a, _ -> b)    (b, a -> _)
  Tuple ATypeV ZipperV

_ -> b == inj "function" $ DPairL' Unit (b :: ATypeV)
(a, _ -> b) == inj "function" $ DPairL' (a :: ATypeV) (b :: ATypeV)
-}

downZipper1 :: ATypeV -> ATypeVF (ZipperVF ATypeV ATypeV)
downZipper1 v =
  ( VF.case_
  # VF.on _name (VF.inj _name <<< rewrap)
  # VF.on _var (VF.inj _var <<< rewrap)
  # VF.on _function (downDPair' id >>> rePair' _function)
  # VF.on _app (downDPair' id >>> rePair' _app)
  ) (unroll v)

extract1 ::
  (Pair ATypeV -> Tuple (DPair' ATypeV Unit) ATypeV) ->
  ATypeV -> Tuple (Maybe (ZipperVF ATypeV Unit)) ATypeV
extract1 choose this =
  ( VF.default (Tuple Nothing this)
  # VF.on _function (lmap (Just <<< VF.inj _function) <<< choose)
  # VF.on _app (lmap (Just <<< VF.inj _app) <<< choose)
  ) (unroll this)

extract1' ::
  (Pair ATypeV -> Tuple (DPair' ATypeV Unit) ATypeV) ->
  ATypeV -> Tuple ZipperV ATypeV
extract1' choose = extract1 choose >>> lmap unroll1

extract1C ::
  (Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC) ->
  ATypeVC -> Tuple (Maybe (ZipperVF ATypeVC Tag)) ATypeVC
extract1C choose this =
  ( VF.default (Tuple Nothing this)
  # VF.on _function (lmap (Just <<< VF.inj _function) <<< choose)
  # VF.on _app (lmap (Just <<< VF.inj _app) <<< choose)
  ) (tail this)

extract1C' ::
  (Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC) ->
  ATypeVC -> Tuple ZipperVC ATypeVC
extract1C' choose v =
  extract1C choose v # lmap (unroll1C (head v))

left :: forall a. Pair a -> Tuple (DPair' a Unit) a
left (Pair l r) = Tuple (DPairL' unit r) l

right :: forall a. Pair a -> Tuple (DPair' a Unit) a
right (Pair l r) = Tuple (DPairR' l unit) r

leftC :: Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC
leftC (Pair l r) = Tuple (DPairL' (head l) r) l

rightC :: Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC
rightC (Pair l r) = Tuple (DPairR' l (head r)) r

unroll1 :: Maybe (ZipperVF ATypeV Unit) -> ZipperV
unroll1 = roll <<< Compose <<< map (_ $> roll (Compose Nothing))

unroll1C :: Tag -> Maybe (ZipperVF ATypeVC Tag) -> ZipperVC
unroll1C h v = h :< Compose (map (mkCofree <@> Compose Nothing) <$> v)

downDPair' :: forall a da. (a -> da) -> Pair a -> Pair (DPair' a da)
downDPair' down (Pair l r) = Pair
  (DPairL' (down l) r)
  (DPairR' l (down r))

-- | A tag consists of the following:
-- |   1. the starting index *relative to the parent*
-- |   2. the length of the string that represents this chunk
type Tag = Tuple (Additive Int) (Additive Int)
-- | A tagged recursive structure of `Cofree` and `Tag`.
type Tagged f = Cofree f Tag
-- | Used before a Cofree is tagged.
type Untagged f = f (Tagged f)
-- | While building up a tag, accumulate a `String` of the current content,
-- | which also gives the index relative to the parent (see `Tag`).
type Tagging a = State String a

-- | Class for monoids that support slicing operations, i.e. indexing a section
-- | of itself.
-- |
-- | Laws (provisional):
-- |   * Length is a monoid morphism:
-- |     * `length mempty == mempty`
-- |     * `length (a <> b) == length a <> length b`
-- |   * `splice mempty (length s) r s == r`
-- |   * `splice i mempty r s == s`
-- |   * `splice i mempty r s == s`
-- |   * `splice (length s) l r s == s`
class Monoid m <= Spliceable m where
  length :: m -> Additive Int
  splice :: Additive Int -> Additive Int -> m -> m -> m

instance spliceableString :: Spliceable String where
  length = Additive <<< String.length
  splice offset size replacement = do
    before <- String.take (unwrap (offset))
    after  <- String.drop (unwrap (offset <> size))
    pure (before <> replacement <> after)

instance spliceableArray :: Spliceable (Array a) where
  length = Additive <<< Array.length
  splice offset size replacement = do
    before <- Array.take (unwrap (offset))
    after  <- Array.drop (unwrap (offset <> size))
    pure (before <> replacement <> after)

take :: forall m. Spliceable m => Additive Int -> m -> m
take = splice mempty <@> mempty
drop :: forall m. Spliceable m => Additive Int -> m -> m
drop i s = splice i (over2 Additive (-) (length s) i) mempty s

tag ::
  forall m.
    Monoid m =>
  State m (Untagged ATypeVF) ->
  Tuple m (Untagged ATypeVF)
tag = swap <<< (runState <@> mempty)

recur ::
  forall m.
    Spliceable m =>
  Tuple m (Untagged ATypeVF) ->
  State m (Tagged ATypeVF)
recur (Tuple s r) = do
  offset <- gets length
  literal s
  pure $ Tuple offset (length s) :< r

literal :: forall m. Monoid m => m -> State m Unit
literal s = modify (_ <> s)

simple :: forall m. ATypeVF Void -> m -> Tuple m (Untagged ATypeVF)
simple v s = Tuple s $ map absurd v

simpleShowConst ::
  forall a b sym bleh.
    IsSymbol sym =>
    RowCons sym (FProxy (Const a)) bleh ATypeVR =>
    Show a =>
  SProxy sym -> Const a b -> Tuple String (ATypeVF (Tagged ATypeVF))
simpleShowConst k v = simple (VF.inj k $ rewrap v) $ show $ unwrap v

rewrap :: forall a b c. Const a b -> Const a c
rewrap (Const a) = Const a

showTagged1P :: Maybe Annot -> Algebra ATypeVF (Tuple String (Untagged ATypeVF))
showTagged1P p = VF.match
  { name: simpleShowConst _name
  , var: simpleShowConst _var
  , function: \(Pair l r) -> wrapTagIf mayNeedFnParen do
      a <- recur l
      literal " -> "
      b <- recur r
      pure (VF.inj _function (Pair a b))
  , app: \(Pair l r) -> wrapTagIf mayNeedAppParen do
      a <- recur l
      literal " "
      b <- recur r
      pure (VF.inj _app (Pair a b))
  --, row: \meh -> tag do
      --literal "meh"
      --pure (VF.inj (SProxy :: SProxy "row") meh)
  }
  where
    wrapTagIf pred v
      | pred p    = tag $ literal "(" *> v <* literal ")"
      | otherwise = tag v

whileAnnotatingDown ::
  forall t f a ann.
    Recursive t f =>
  Maybe ann -> (f t -> f (Tuple ann t)) ->
  (Maybe ann -> Algebra f a) -> t -> a
whileAnnotatingDown ann0 mkAnn f = f ann0 <<< go
  where
    go t = mkAnn (project t) <#>
      \(Tuple ann t) -> f (Just ann) (go t)

data Annot = FnParen | AppParen | FnAppParen | None
derive instance eqAnnot :: Eq Annot
needsFnParen :: Annot -> Boolean
needsFnParen FnParen = true
needsFnParen FnAppParen = true
needsFnParen _ = false
needsAppParen :: Annot -> Boolean
needsAppParen AppParen = true
needsAppParen FnAppParen = true
needsAppParen _ = false
mayNeedFnParen :: Maybe Annot -> Boolean
mayNeedFnParen = maybe false needsFnParen
mayNeedAppParen :: Maybe Annot -> Boolean
mayNeedAppParen = maybe false needsAppParen
-- instance heytingAlgebraAnnot :: HeytingAlgebra Annot
annotPrec :: forall a. ATypeVF a -> ATypeVF (Tuple Annot a)
annotPrec = VF.match
  { name: VF.inj _name <<< rewrap
  , var: VF.inj _var <<< rewrap
  , function: VF.inj _function <<< bimapPair (Tuple FnParen) (Tuple None)
  , app: VF.inj _app <<< bimapPair (Tuple FnParen) (Tuple FnAppParen)
  } where bimapPair f g (Pair a b) = Pair (f a) (g b)

showTagged :: forall t. Recursive t ATypeVF =>
  t -> Tuple String (Untagged ATypeVF)
showTagged = whileAnnotatingDown Nothing annotPrec showTagged1P

showTagged' :: forall t. Recursive t ATypeVF =>
  Maybe Annot -> t -> Tuple String (Untagged ATypeVF)
showTagged' ann = whileAnnotatingDown ann annotPrec showTagged1P

showAType :: forall t. Recursive t ATypeVF =>
  t -> String
showAType = showTagged >>> fst

showAType' :: forall t. Recursive t ATypeVF =>
  Maybe Annot -> t -> String
showAType' ann = showTagged' ann >>> fst

evalFrom :: forall m. Spliceable m =>
  Additive Int -> Tuple m (Untagged ATypeVF) -> Tuple m ATypeVC
evalFrom st (Tuple s v) =
  Tuple s $ Tuple st (length s) :< v

showTaggedFrom :: forall t. Recursive t ATypeVF =>
  Additive Int -> Maybe Annot -> t -> Tuple String ATypeVC
showTaggedFrom i ann = showTagged' ann >>> evalFrom i

modifyHead :: forall f a. (a -> a) -> Cofree f a -> Cofree f a
modifyHead f = lift2 (:<) (f <<< head) tail

patch ::
  ZipperVC -> ATypeV -> String ->
  (Additive Int -> Maybe Annot -> Tuple String ATypeVC)
patch positioned replacement old i =
  let
    Tuple offset size = head positioned
  in case tail positioned of
    Compose Nothing -> \ann ->
      let start = i <> offset in
      showTaggedFrom offset ann replacement # lmap
        (splice start size <@> old)
    Compose (Just inside) -> const
      let
        next da offset ann f =
          let
            Tuple new updated = patch da replacement old i $ Just ann
            diff = Additive $ ((-) `on` (length >>> unwrap)) new old
          in Tuple new (Tuple offset (size <> diff) :< f diff updated)
        handle ::
          forall sym bleh.
            IsSymbol sym =>
            RowCons sym (FProxy Pair) bleh ATypeVR =>
          SProxy sym -> Annot -> Annot ->
          DPair' ATypeVC ZipperVC -> Tuple String ATypeVC
        handle k ann _ (DPairL' da a) =
          next da mempty ann
            \diff updated ->
              VF.inj k (Pair updated $ modifyHead (_ <> Tuple diff mempty) a)
        handle k _ ann (DPairR' a da) =
          next da offset ann
            \_ updated ->
              VF.inj k (Pair a updated)
      in inside # VF.match
        { function: handle _function FnParen None
        , app: handle _app FnParen FnAppParen
        }

showFields :: forall a. StrMap (Tuple a String) -> String
showFields m = joinWith ", " $ StrMap.toUnfoldable m <#> \(Tuple k (Tuple _ v)) ->
  k <> " :: " <> v

data AKindF a
  = KindName (Qualified Proper)
  | KindFunction a a
  | KindApp a a
  | KindRow a
newtype AKind = AKind (Mu AKindF)
derive instance functorAKindF :: Functor AKindF
instance showAKind :: Show AKind where
  show (AKind inner) = cata showInner inner
    where
      showInner :: Algebra AKindF String
      showInner (KindName q) = show q
      showInner (KindFunction a b) = wrap a <> " -> " <> wrap b
      showInner (KindApp f a) = wrap f <> " " <> wrap a
      showInner (KindRow a) = "# " <> a

type TypeAbses = Array TypeAbs
data TypeAbs = TypeAbs Ident (Maybe AKind)
instance showTypeAbs :: Show TypeAbs where
  show (TypeAbs i Nothing) = show i
  show (TypeAbs i (Just k)) = "(" <> show i <> " :: " <> show k <> ")"
data DataTypeDef = DataTypeDef TypeAbses DataType
type DataTypeDecls = Map Proper DataTypeDef
showDataTypeDecls :: DataTypeDecls -> String
showDataTypeDecls = joinWith "\n" <<< Map.toAscUnfoldable >>> map
  \(Tuple name (DataTypeDef vs dt)) ->
    let vars = joinWithIfNE " " show vs in
    show (declKeyword dt) <> " " <> show name <> vars <> " = " <> show dt

type Modules = Map Module ModuleData
type ModuleData =
  { imports :: ImportModules
  , datatypes :: DataTypeDecls
  }
showModuleData :: ModuleData -> String
showModuleData = do
  imports <- showImportModules <<< _.imports
  datatypes <- showDataTypeDecls <<< _.datatypes
  pure (imports <> "\n\n" <> datatypes)

module Types where

import Prelude

import Control.Apply (lift2)
import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
import Control.Monad.State (State, gets, modify, runState)
import Data.Array (concatMap, last, uncons, unsnoc)
import Data.Array (fromFoldable) as Array
import Data.Bifunctor (lmap)
import Data.Const (Const(..))
import Data.Either (Either)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Mu (Mu, roll, unroll)
import Data.Functor.Product (Product(..))
import Data.Functor.Variant (FProxy, SProxy(..), VariantF)
import Data.Functor.Variant as VF
import Data.Identity (Identity(..))
import Data.Map (Map)
import Data.Map (fromFoldable, toAscUnfoldable, singleton, insert) as Map
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Pair (Pair(..))
import Data.Set (Set)
import Data.Set (toUnfoldable) as Set
import Data.StrMap (StrMap)
import Data.StrMap (toUnfoldable, insert) as StrMap
import Data.String (Pattern(..), Replacement(..), drop, joinWith, length, replaceAll, take)
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..), fst, snd, swap, uncurry)
import Matryoshka (class Recursive, Algebra, cata, project)
import Unsafe.Coerce (unsafeCoerce)

onlyType :: Proper -> Import
onlyType = Type <@> mempty
dataModule :: Array Proper -> Module
dataModule rest = Module (Proper "Data" :| rest)
dataImport :: Proper -> Tuple Module ImportModule
dataImport name =
  pure (Type name mempty) `importFrom`
    dataModule (pure name)
importAll :: ImportModule
importAll = ImportModule (pure mempty) mempty
importAllFrom :: Module -> Tuple Module ImportModule
importAllFrom = Tuple <@> importAll
importFrom :: Imports -> Module -> Tuple Module ImportModule
importFrom is = Tuple <@> ImportModule (pure is) mempty

aType :: ATypeVF ATypeV -> ATypeV
aType = roll

aTypeConst ::
  forall sym a bleh.
    IsSymbol sym =>
    RowCons sym (FProxy (Const a)) bleh ATypeVR =>
  SProxy sym -> a -> ATypeV
aTypeConst k a = aType $ VF.inj k $ Const a

aTypePair ::
  forall sym bleh.
    IsSymbol sym =>
    RowCons sym (FProxy Pair) bleh ATypeVR =>
  SProxy sym -> ATypeV -> ATypeV -> ATypeV
aTypePair k a b  = aType $ VF.inj k $ Pair a b

aTypeProduct ::
  forall sym f g bleh.
    IsSymbol sym =>
    Functor f =>
    Functor g =>
    RowCons sym (FProxy (Product f g)) bleh ATypeVR =>
  SProxy sym -> f ATypeV -> g ATypeV -> ATypeV
aTypeProduct k a b = aType $ VF.inj k $ Product $ Tuple a b

aTypeApp :: ATypeV -> ATypeV -> ATypeV
aTypeApp = aTypePair _app

aTypeFunction :: ATypeV -> ATypeV -> ATypeV
aTypeFunction = aTypePair _function

aTypeName :: Qualified Proper -> ATypeV
aTypeName = aTypeConst _name

aTypeVar :: Ident -> ATypeV
aTypeVar = aTypeConst _var

typeAbsType :: Ident -> TypeAbs
typeAbsType = TypeAbs <@> Nothing

newType :: Proper -> ATypeV -> DataTypeDef
newType name typ = DataTypeDef mempty $ SumType $ Map.singleton name $ pure typ

namedNewType :: Proper -> ATypeV -> Tuple Proper DataTypeDef
namedNewType = lift2 compose Tuple newType

alias :: Proper -> NonEmpty Array (Qualified Proper) -> Tuple Proper DataTypeDef
alias name as = Tuple name $ DataTypeDef mempty $ TypeAlias (chainl aTypeApp as)

chainl :: (ATypeV -> ATypeV -> ATypeV) -> NonEmpty Array (Qualified Proper) -> ATypeV
chainl app (fn :| args) = go (aTypeName fn) args
  where
    go :: ATypeV -> Array (Qualified Proper) -> ATypeV
    go f as = case uncons as of
      Nothing -> f
      Just { head, tail } ->
        go (app f (aTypeName head)) tail

chainr :: (ATypeV -> ATypeV -> ATypeV) -> NonEmpty Array (Qualified Proper) -> ATypeV
chainr app (fn :| args) = go (aTypeName fn) args
  where
    go :: ATypeV -> Array (Qualified Proper) -> ATypeV
    go f as = case unsnoc as of
      Nothing -> f
      Just { init, last } ->
        go (app (aTypeName last) f) init

qualifyP :: Proper -> Qualified Proper
qualifyP p@(Proper name) = case name of
  "NonEmpty" -> qualifyData p
  "Either" -> qualifyData p
  "Map" -> qualifyData p
  "String" -> prim p
  _ -> Unqualified p

qualifyData :: Proper -> Qualified Proper
qualifyData p = Qualified (dataModule $ pure p) p

prim :: Proper -> Qualified Proper
prim = Qualified (Module (Proper "Prim" :| mempty))

qualify :: Tuple Module ImportModule -> Imports -> Tuple Module ImportModule
qualify (Tuple name (ImportModule mims mp)) is =
  Tuple name (ImportModule mims mp')
  where
    mp' = Map.insert (Module (lastOf name :| [])) is mp

thisModule :: ModuleData
thisModule =
  { imports: Map.fromFoldable
    [ importAllFrom $ Module $ Proper <$> "Prelude" :| mempty
    , dataImport $ Proper "Either"
    , [onlyType $ Proper "Mu"] `importFrom`
      (dataModule $ Proper <$> ["Functor", "Mu"])
    , dataImport (Proper "Map") `qualify`
        (Value <<< Ident <$> ["fromFoldable", "toAscUnfoldable", "singleton", "insert"])
    , dataImport $ Proper "Maybe"
    , [Class $ Proper "Monoid", Value $ Ident "mempty"] `importFrom`
      (dataModule $ pure $ Proper "Monoid")
    , dataImport (Proper "NonEmpty") <#> flip append
        (ImportModule (pure (pure (Operator (Op ":|")))) mempty)
    , dataImport $ Proper "Set"
    , dataImport $ Proper "StrMap"
    , [Type (Proper "Tuple") (pure AllCs)] `importFrom`
      (dataModule $ pure $ Proper "Tuple")
    ]
  , datatypes: Map.fromFoldable
    [ Proper "Module" `namedNewType`
        chainl aTypeApp (Unqualified <<< Proper <$> "NonEmpty" :| ["Array", "Proper"])
    , Tuple (Proper "Qualified") $ DataTypeDef [typeAbsType $ Ident "a"] $
        SumType $ Map.fromFoldable
        [ Tuple (Proper "Qualified")
          [ atnunqp "Module"
          , aTypeVar $ Ident "a"
          ]
        , Tuple (Proper "Unqualified") $ pure $ aTypeVar $ Ident "a"
        ]
    , Proper "Proper" `namedNewType` aTypeName (Unqualified $ Proper "String")
    , Proper "Ident" `namedNewType` aTypeName (Unqualified $ Proper "String")
    , Proper "Op" `namedNewType` aTypeName (Unqualified $ Proper "String")
    , Proper "ProperOp" `alias`
      ( Unqualified <<< Proper <$> "Either" :| ["Proper", "Op"] )
    , Proper "IdentOp" `alias`
      ( Unqualified <<< Proper <$> "Either" :| ["Ident", "Op"] )
    , Proper "ImportModules" `alias`
      ( Unqualified <<< Proper <$> "Map" :| ["Module", "ImportModule"] )
    , Tuple (Proper "ImportModule") $ DataTypeDef mempty $
        SumType $ Map.singleton (Proper "ImportModule") $
        [ aTypeApp (atnunqp "Maybe") $ atnunqp "Imports"
        , chainl aTypeApp (Unqualified <<< Proper <$> "Map" :| ["Module", "Imports"])
        ]
    , Tuple (Proper "FUNCTION") $ DataTypeDef mempty $
        TypeAlias $
          testType
    ]
  }

atnunqp :: String -> ATypeV
atnunqp = aTypeName <<< Unqualified <<< Proper

testType :: ATypeV
testType = chainl aTypeFunction (Unqualified <<< Proper <$> "Module" :| ["Imports", "ImportModule"])
  `aTypeFunction` ((atnunqp "Map" `aTypeApp` (atnunqp "Maybe" `aTypeApp` atnunqp "Module"))
    `aTypeApp` (atnunqp "Meh" `aTypeFunction` atnunqp "Eh"))

otherTest :: ATypeV
otherTest = chainr aTypeFunction (Unqualified <<< Proper <$> "Heus" :| ["Yo", "Hey"])

testTypeL :: Tuple (Maybe (ZipperVF ATypeV Unit)) ATypeV
testTypeL = extract1 left testType

testTypeLS :: String
testTypeLS = case testTypeL of
  Tuple (Just z) h ->
    "(" <> simpleShowZ1 showAType z <> ", " <> showAType h <> ")"
  Tuple Nothing h -> showAType h

testTypeC :: Tuple String ATypeVC
testTypeC = case showTagged testType of
  Tuple s v -> Tuple s $ Tuple mempty (Additive (length s)) :< v

testTypeCS :: String
testTypeCS = cofrecurse (snd testTypeC)

testTypeLC :: Tuple (Maybe (ZipperVF ATypeVC Tag)) ATypeVC
testTypeLC = extract1C rightC (snd testTypeC)

testTypeLC' :: Tuple ZipperVC ATypeVC
testTypeLC' = extract1C' rightC (snd testTypeC)

testTypeLSC :: String
testTypeLSC = case testTypeLC of
  Tuple (Just z) h ->
    "(" <> simpleShowZ1 (forget >>> showAType) z <> ", " <> showAType (forget h) <> ")"
  Tuple Nothing h -> showAType (forget h)

testPatchSameR :: Tuple String ATypeVC
testPatchSameR = uncurry patch (map forget testTypeLC') (fst testTypeC) mempty Nothing

testPatchSameL :: Tuple String ATypeVC
testPatchSameL = uncurry patch (map forget $ extract1C' leftC (snd testTypeC)) (fst testTypeC) mempty Nothing

testPatchExplodeR :: Tuple String ATypeVC
testPatchExplodeR = patch (fst testTypeLC') otherTest (fst testTypeC) mempty Nothing

testPatchExplodeL :: Tuple String ATypeVC
testPatchExplodeL = patch (fst $ extract1C' leftC (snd testTypeC)) otherTest (fst testTypeC) mempty Nothing

forget :: forall f a. Functor f => Cofree f a -> Mu f
forget v = tail v # map forget # roll

badindent :: String -> String
badindent = replaceAll (Pattern "\n") (Replacement "\n  ")

cofrecurse :: ATypeVC -> String
cofrecurse v = let t = " >: " <> show (head v) in
  ( VF.case_
  # VF.on _var (unwrap >>> show >>> (_ <> t))
  # VF.on _name (unwrap >>> show >>> (_ <> t))
  # VF.on _function (\(Pair l r) -> "function" <> t <>
      badindent ("\n" <> cofrecurse l <> "\n" <> cofrecurse r))
  # VF.on _app (\(Pair l r) -> "app" <> t <>
      badindent ("\n" <> cofrecurse l <> "\n" <> cofrecurse r))
  ) (tail v)

newtype Module = Module (NonEmpty Array Proper)
derive newtype instance eqModule :: Eq Module
derive newtype instance ordModule :: Ord Module
instance showModule :: Show Module where
  show (Module (top :| [])) = show top
  show (Module (top :| rest)) =
    show top <> "." <> joinWith "." (show <$> rest)
lastOf :: Module -> Proper
lastOf (Module (n :| ns)) = fromMaybe n $ last ns
data Qualified a
  = Qualified Module a
  | Unqualified a
instance showQualified :: Show a => Show (Qualified a) where
  show (Unqualified a) = show a
  show (Qualified m a) = show m <> "." <> show a
newtype Proper = Proper String
derive newtype instance eqProper :: Eq Proper
derive newtype instance ordProper :: Ord Proper
instance showProper :: Show Proper where
  show (Proper p) = p
newtype Ident = Ident String
derive newtype instance eqIdent :: Eq Ident
derive newtype instance ordIdent :: Ord Ident
instance showIdent :: Show Ident where
  show (Ident p) = p
newtype Op = Op String
derive newtype instance eqOp :: Eq Op
derive newtype instance ordOp :: Ord Op
instance showOp :: Show Op where
  show (Op p) = p
type ProperOp = Either Op Proper
type IdentOp = Either Op Ident

type ImportModules = Map Module ImportModule
data ImportModule =
  ImportModule
    (Maybe Imports)
    (Map Module Imports)
instance semigroupImportModule :: Semigroup ImportModule where
  append (ImportModule is as) (ImportModule iz az) =
    ImportModule (is <> iz) (as <> az)
instance monoidImportModule :: Monoid ImportModule where
  mempty = ImportModule mempty mempty
showImportModules :: ImportModules -> String
showImportModules = joinWith "\n" <<< Map.toAscUnfoldable >>> concatMap
  \(Tuple modul (ImportModule mims aliases)) ->
    let
      showUnq []  = "import " <> show modul
      showUnq ims = "import " <> show modul <> " " <>
        "(" <> joinWith ", " (show <$> ims) <> ")"
      showQ (Tuple mod alias) = showUnq alias <> " as " <> show mod
    in Array.fromFoldable (showUnq <$> mims) <>
      (showQ <$> Map.toAscUnfoldable aliases)

type Imports = Array Import
data Import
  = Value Ident
  | Type Proper (Maybe Constructors)
  | Class Proper
  | Kind Proper
  | Operator Op
  | TypeOperator Op
instance showImport :: Show Import where
  show (Value i) = show i
  show (Type p Nothing) = show p
  show (Type p (Just cs)) = show p <> "(" <> show cs <> ")"
  show (Class p) = "class " <> show p
  show (Kind p) = "kind " <> show p
  show (Operator o) = "(" <> show o <> ")"
  show (TypeOperator o) = "type (" <> show o <> ")"
data Constructors = AllCs | SpecificCs (Set Proper)
instance showConstructors :: Show Constructors where
  show (SpecificCs ps) = joinWith ", " (show <$> Set.toUnfoldable ps)
  show AllCs = ".."
instance semigroupConstructors :: Semigroup Constructors where
  append (SpecificCs a) (SpecificCs b) = SpecificCs (a <> b)
  append _ _ = AllCs
instance monoidConstructors :: Monoid Constructors where
  mempty = SpecificCs mempty

wrap :: String -> String
wrap a = "(" <> a <> ")"

joinWithIfNE :: forall a. String -> (a -> String) -> Array a -> String
joinWithIfNE _ _ [] = ""
joinWithIfNE sep f as = sep <> joinWith sep (f <$> as)

data DataType
  = TypeAlias ATypeV
  | SumType (Map Proper (Array ATypeV))
instance showDataType :: Show DataType where
  show (TypeAlias t) = showAType t
  show (SumType m) = joinWith " | " $ Map.toAscUnfoldable m <#> \(Tuple c ts) ->
    show c <> joinWithIfNE " " (showAType' (Just FnAppParen)) ts
data DeclKeyword = TType | TNewtype | TData
derive instance eqDeclKeyword :: Eq DeclKeyword
derive instance ordDeclKeyword :: Ord DeclKeyword
instance showDeclKeyword :: Show DeclKeyword where
  show TType = "type"
  show TNewtype = "newtype"
  show TData = "data"
declKeyword :: DataType -> DeclKeyword
declKeyword (TypeAlias _) = TType
declKeyword (SumType m)
  | [Tuple _ [_]] <- Map.toAscUnfoldable m
    = TNewtype
  | otherwise
    = TData
type ATypeVR =
  ( name     :: FProxy (Const (Qualified Proper))
  , var      :: FProxy (Const Ident)
  , function :: FProxy Pair
  , app      :: FProxy Pair
  -- , row      :: FProxy (Product StrMap Maybe)
  )
type ATypeVF = VariantF ATypeVR
type ATypeV = Mu ATypeVF
type ATypeVC = Tagged ATypeVF

data DPair' a da = DPairL' da a | DPairR' a da
derive instance functorDPair' :: Functor (DPair' a)
instance showDPair' :: (Show a, Show da) => Show (DPair' a da) where
  show (DPairL' da a) = "(DPairL' " <> show da <> " " <> show a <> ")"
  show (DPairR' a da) = "(DPairR' " <> show a <> " " <> show da <> ")"
data DStrMap' a da = DStrMap' String da (StrMap a)
type DATypeVR' a da =
  ( name     :: Unit
  , var      :: Unit
  , function :: DPair' a da
  , app      :: DPair' a da
  -- , row      :: Tuple (DStrMap' a da) da
  )
data DMu' f df = DIn' (df (Mu f) (DMu' f df)) (DMu' f df)

type ZipperVR a =
  ( function :: FProxy (DPair' a)
  , app :: FProxy (DPair' a)
  )
type ZipperVF a = VariantF (ZipperVR a)
type ZipperVF' a = Compose Maybe (ZipperVF a)
type ZipperVF'' a = Compose Maybe (Compose (Tuple Tag) (ZipperVF a))
type ZipperV = Mu (ZipperVF' ATypeV)
type ZipperVC = Tagged (ZipperVF' ATypeVC)

simpleShowZ :: forall a. (a -> String) -> Algebra (ZipperVF a) String
simpleShowZ inner = VF.match
  { function: showDPair' " -> "
  , app: showDPair' " "
  --, row: const "()"
  }
  where
    showDPair' :: String -> DPair' a String -> String
    showDPair' s (DPairL' da a) = "{" <> da <> "}" <> s <> inner a
    showDPair' s (DPairR' a da) = inner a <> s <> "{" <> da <> "}"

simpleShowZ1 :: forall a s. Show s => (a -> String) -> ZipperVF a s -> String
simpleShowZ1 inner v = simpleShowZ inner (v <#> show)

_name = SProxy :: SProxy "name"
_var = SProxy :: SProxy "var"
_function = SProxy :: SProxy "function"
_app = SProxy :: SProxy "app"

downZipperVF :: forall a da. (a -> da) -> ATypeVF a -> ATypeVF (ZipperVF a da)
downZipperVF down = VF.case_
  # VF.on _name (VF.inj _name <<< rewrap)
  # VF.on _var (VF.inj _var <<< rewrap)
  # VF.on _function (downDPair' down >>> rePair' _function)
  # VF.on _app (downDPair' down >>> rePair' _app)

rePair' ::
  forall a da sym bleh meh.
    IsSymbol sym =>
    RowCons sym (FProxy Pair) bleh ATypeVR =>
    RowCons sym (FProxy (DPair' a)) meh (ZipperVR a) =>
  SProxy sym -> Pair (DPair' a da) -> ATypeVF (ZipperVF a da)
rePair' sym = VF.inj sym <<< map (VF.inj sym)

{-
downZipperVF' :: forall a da. (a -> da) -> ATypeVF a -> ZipperVF' a da
downZipperVF' down = VF.default (Compose Nothing)
    # VF.on _function (downDPair' down >>> map (VF.inj _function) >>> Just >>> Compose)
    # VF.on _app (downDPair' down >>> map (VF.inj _app) >>> Just >>> Compose)
-}

{-
     ATypeV
down (a -> b) =
              ATypeVF ()
              ->
  (a, _ -> b)    (b, a -> _)
  Tuple ATypeV ZipperV

_ -> b == inj "function" $ DPairL' Unit (b :: ATypeV)
(a, _ -> b) == inj "function" $ DPairL' (a :: ATypeV) (b :: ATypeV)
-}

downZipper1 :: ATypeV -> ATypeVF (ZipperVF ATypeV ATypeV)
downZipper1 v =
  ( VF.case_
  # VF.on _name (VF.inj _name <<< rewrap)
  # VF.on _var (VF.inj _var <<< rewrap)
  # VF.on _function (downDPair' id >>> rePair' _function)
  # VF.on _app (downDPair' id >>> rePair' _app)
  ) (unroll v)

extract1 ::
  (Pair ATypeV -> Tuple (DPair' ATypeV Unit) ATypeV) ->
  ATypeV -> Tuple (Maybe (ZipperVF ATypeV Unit)) ATypeV
extract1 choose this =
  ( VF.default (Tuple Nothing this)
  # VF.on _function (lmap (Just <<< VF.inj _function) <<< choose)
  # VF.on _app (lmap (Just <<< VF.inj _app) <<< choose)
  ) (unroll this)

extract1' ::
  (Pair ATypeV -> Tuple (DPair' ATypeV Unit) ATypeV) ->
  ATypeV -> Tuple ZipperV ATypeV
extract1' choose = extract1 choose >>> lmap unroll1

extract1C ::
  (Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC) ->
  ATypeVC -> Tuple (Maybe (ZipperVF ATypeVC Tag)) ATypeVC
extract1C choose this =
  ( VF.default (Tuple Nothing this)
  # VF.on _function (lmap (Just <<< VF.inj _function) <<< choose)
  # VF.on _app (lmap (Just <<< VF.inj _app) <<< choose)
  ) (tail this)

extract1C' ::
  (Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC) ->
  ATypeVC -> Tuple ZipperVC ATypeVC
extract1C' choose v =
  extract1C choose v # lmap (unroll1C (head v))

left :: forall a. Pair a -> Tuple (DPair' a Unit) a
left (Pair l r) = Tuple (DPairL' unit r) l

right :: forall a. Pair a -> Tuple (DPair' a Unit) a
right (Pair l r) = Tuple (DPairR' l unit) r

leftC :: Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC
leftC (Pair l r) = Tuple (DPairL' (head l) r) l

rightC :: Pair ATypeVC -> Tuple (DPair' ATypeVC Tag) ATypeVC
rightC (Pair l r) = Tuple (DPairR' l (head r)) r

unroll1 :: Maybe (ZipperVF ATypeV Unit) -> ZipperV
unroll1 = roll <<< Compose <<< map (_ $> roll (Compose Nothing))

unroll1C :: Tag -> Maybe (ZipperVF ATypeVC Tag) -> ZipperVC
unroll1C h v = h :< Compose (map (mkCofree <@> Compose Nothing) <$> v)

downDPair' :: forall a da. (a -> da) -> Pair a -> Pair (DPair' a da)
downDPair' down (Pair l r) = Pair
  (DPairL' (down l) r)
  (DPairR' l (down r))

foreign import data D :: Type -> Type
toD :: forall f df. Diff f df => df -> D f
toD = unsafeCoerce
fromD :: forall f df. Diff f df => D f -> df
fromD = unsafeCoerce
foreign import data DF :: (Type -> Type) -> (Type -> Type)
toDF :: forall f df x. Diff1 f df => df x -> DF f x
toDF = unsafeCoerce
fromDF :: forall f df x. Diff1 f df => DF f x -> df x
fromDF = unsafeCoerce
data Z x = Z (D x) x
data ZF f x = ZF (DF f x) x
class Diff a da | a -> da where
  up :: Z a -> a
class
  ( Functor f
  -- , Functor df
  ) <= Diff1 (f :: Type -> Type) (df :: Type -> Type) | f -> df where
    upF     :: forall x dx. Diff x dx => ZF f x  ->           f x
    --aroundF :: forall x. ZF f x  ->  ZF f (ZF f x)
    --downF   :: forall x.    f x  ->     f (ZF f x)
instance diff1StrMap :: Diff1 StrMap DStrMap where
  upF (ZF eh a) =
    case fromDF eh of
      DStrMap key da rest ->
        StrMap.insert key (up (Z da a)) rest
instance diff1Const :: Diff1 (Const a) (Const Void) where
  upF (ZF eh _) = absurd (unwrap (fromDF eh))
instance diff1Identity :: Diff1 Identity (Const Unit) where
  upF (ZF _ x) = Identity x
instance diff1Pair :: Diff1 Pair DPair where
  upF (ZF eh a) =
    case fromDF eh of
      DPairR l da   -> Pair l (up (Z da a))
      DPairL   da r -> Pair   (up (Z da a)) r
{-
instance diff1Compose ::
  ( Diff1 f df
  , Diff1 g fg
  ) => Diff1 (Compose f g) (Product (Compose df g) dg) where
    upF (ZF eh x) =
      case fromDF eh of
        (Product (Tuple (Compose dfg) dg)) ->
          let
            g = upF (ZF dg x)
          in Compose $ ?finalize dg x
-}

data DPair a = DPairL (D a) a | DPairR a (D a)
instance functorDPair :: Functor D => Functor DPair where
  map f (DPairL da a) = DPairL (map f da) (f a)
  map f (DPairR a da) = DPairR (f a) (map f da)
data DStrMap a = DStrMap String (D a) (StrMap a)
data DMu f = DIn ((DF f) (Mu f)) (DMu f)
type DATypeVR =
  ( name     :: FProxy (Const Unit)
  , var      :: FProxy (Const Unit)
  , function :: FProxy (DPair)
  , app      :: FProxy (DPair)
  -- , row      :: FProxy (Product D DStrMap)
  )

-- | A tag consists of the following:
-- |   1. the starting index *relative to the parent*
-- |   2. the length of the string that represents this chunk
type Tag = Tuple (Additive Int) (Additive Int)
-- | A tagged recursive structure of `Cofree` and `Tag`.
type Tagged f = Cofree f Tag
-- | Used before a Cofree is tagged.
type Untagged f = f (Tagged f)
-- | While building up a tag, accumulate a `String` of the current content,
-- | which also gives the index relative to the parent (see `Tag`).
type Tagging a = State String a

tag :: Tagging (Untagged ATypeVF) -> Tuple String (Untagged ATypeVF)
tag = swap <<< (runState <@> mempty)

recur :: Tuple String (Untagged ATypeVF) -> Tagging (Tagged ATypeVF)
recur (Tuple s r) = do
  offset <- gets (Additive <<< length)
  literal s
  pure $ Tuple offset (Additive (length s)) :< r

literal :: String -> Tagging Unit
literal s = modify (_ <> s)

simple :: ATypeVF Void -> String -> Tuple String (Untagged ATypeVF)
simple v s = Tuple s $ map absurd v

simpleShowConst ::
  forall a b sym bleh.
    IsSymbol sym =>
    RowCons sym (FProxy (Const a)) bleh ATypeVR =>
    Show a =>
  SProxy sym -> Const a b -> Tuple String (ATypeVF (Tagged ATypeVF))
simpleShowConst k v = simple (VF.inj k $ rewrap v) $ show $ unwrap v

rewrap :: forall a b c. Const a b -> Const a c
rewrap (Const a) = Const a

showTagged1P :: Maybe Annot -> Algebra ATypeVF (Tuple String (Untagged ATypeVF))
showTagged1P p = VF.match
  { name: simpleShowConst _name
  , var: simpleShowConst _var
  , function: \(Pair l r) -> wrapTagIf mayNeedFnParen do
      a <- recur l
      literal " -> "
      b <- recur r
      pure (VF.inj _function (Pair a b))
  , app: \(Pair l r) -> wrapTagIf mayNeedAppParen do
      a <- recur l
      literal " "
      b <- recur r
      pure (VF.inj _app (Pair a b))
  --, row: \meh -> tag do
      --literal "meh"
      --pure (VF.inj (SProxy :: SProxy "row") meh)
  }
  where
    wrapTagIf pred v
      | pred p    = tag $ literal "(" *> v <* literal ")"
      | otherwise = tag v

whileAnnotatingDown ::
  forall t f a ann.
    Recursive t f =>
  Maybe ann -> (f t -> f (Tuple ann t)) ->
  (Maybe ann -> Algebra f a) -> t -> a
whileAnnotatingDown ann0 mkAnn f = f ann0 <<< go
  where
    go t = mkAnn (project t) <#>
      \(Tuple ann t) -> f (Just ann) (go t)

data Annot = FnParen | AppParen | FnAppParen | None
derive instance eqAnnot :: Eq Annot
needsFnParen :: Annot -> Boolean
needsFnParen FnParen = true
needsFnParen FnAppParen = true
needsFnParen _ = false
needsAppParen :: Annot -> Boolean
needsAppParen AppParen = true
needsAppParen FnAppParen = true
needsAppParen _ = false
mayNeedFnParen :: Maybe Annot -> Boolean
mayNeedFnParen = maybe false needsFnParen
mayNeedAppParen :: Maybe Annot -> Boolean
mayNeedAppParen = maybe false needsAppParen
-- instance heytingAlgebraAnnot :: HeytingAlgebra Annot
annotPrec :: forall a. ATypeVF a -> ATypeVF (Tuple Annot a)
annotPrec = VF.match
  { name: VF.inj _name <<< rewrap
  , var: VF.inj _var <<< rewrap
  , function: VF.inj _function <<< bimapPair (Tuple FnParen) (Tuple None)
  , app: VF.inj _app <<< bimapPair (Tuple FnParen) (Tuple FnAppParen)
  } where bimapPair f g (Pair a b) = Pair (f a) (g b)

showTagged :: forall t. Recursive t ATypeVF =>
  t -> Tuple String (Untagged ATypeVF)
showTagged = whileAnnotatingDown Nothing annotPrec showTagged1P

showTagged' :: forall t. Recursive t ATypeVF =>
  Maybe Annot -> t -> Tuple String (Untagged ATypeVF)
showTagged' ann = whileAnnotatingDown ann annotPrec showTagged1P

showAType :: forall t. Recursive t ATypeVF => t -> String
showAType = showTagged >>> fst

showAType' :: forall t. Recursive t ATypeVF => Maybe Annot -> t -> String
showAType' ann = showTagged' ann >>> fst

evalFrom :: Additive Int -> Tuple String (Untagged ATypeVF) -> Tuple String ATypeVC
evalFrom st (Tuple s v) =
  Tuple s $ Tuple st (Additive (length s)) :< v

showTaggedFrom :: forall t. Recursive t ATypeVF =>
  Additive Int -> Maybe Annot -> t -> Tuple String ATypeVC
showTaggedFrom i ann = showTagged' ann >>> evalFrom i

modifyHead :: forall f a. (a -> a) -> Cofree f a -> Cofree f a
modifyHead f = lift2 (:<) (f <<< head) tail

patch ::
  ZipperVC -> ATypeV -> String ->
  (Additive Int -> Maybe Annot -> Tuple String ATypeVC)
patch positioned replacement old i =
  let
    Tuple offset size = head positioned
  in case tail positioned of
    Compose Nothing -> \ann ->
      let
        before = take (unwrap (i <> offset)) old
        after  = drop (unwrap (i <> offset <> size)) old
        Tuple slice node = showTaggedFrom offset ann replacement
        spliced = before <> slice <> after
      in Tuple spliced node
    Compose (Just inside) -> const
      let
        next da offset ann f =
          let
            Tuple new updated = patch da replacement old i $ Just ann
            diff = Additive $ ((-) `on` length) new old
          in Tuple new (Tuple offset (size <> diff) :< f diff updated)
        handle ::
          forall sym bleh.
            IsSymbol sym =>
            RowCons sym (FProxy Pair) bleh ATypeVR =>
          SProxy sym -> Annot -> Annot ->
          DPair' ATypeVC ZipperVC -> Tuple String ATypeVC
        handle k ann _ (DPairL' da a) =
          next da mempty ann
            \diff updated ->
              VF.inj k (Pair updated $ modifyHead (_ <> Tuple diff mempty) a)
        handle k _ ann (DPairR' a da) =
          next da offset ann
            \_ updated ->
              VF.inj k (Pair a updated)
      in inside # VF.match
        { function: handle _function FnParen None
        , app: handle _app FnParen FnAppParen
        }

showFields :: forall a. StrMap (Tuple a String) -> String
showFields m = joinWith ", " $ StrMap.toUnfoldable m <#> \(Tuple k (Tuple _ v)) ->
  k <> " :: " <> v

data AKindF a
  = KindName (Qualified Proper)
  | KindFunction a a
  | KindApp a a
  | KindRow a
newtype AKind = AKind (Mu AKindF)
derive instance functorAKindF :: Functor AKindF
instance showAKind :: Show AKind where
  show (AKind inner) = cata showInner inner
    where
      showInner :: Algebra AKindF String
      showInner (KindName q) = show q
      showInner (KindFunction a b) = wrap a <> " -> " <> wrap b
      showInner (KindApp f a) = wrap f <> " " <> wrap a
      showInner (KindRow a) = "# " <> a

type TypeAbses = Array TypeAbs
data TypeAbs = TypeAbs Ident (Maybe AKind)
instance showTypeAbs :: Show TypeAbs where
  show (TypeAbs i Nothing) = show i
  show (TypeAbs i (Just k)) = "(" <> show i <> " :: " <> show k <> ")"
data DataTypeDef = DataTypeDef TypeAbses DataType
type DataTypeDecls = Map Proper DataTypeDef
showDataTypeDecls :: DataTypeDecls -> String
showDataTypeDecls = joinWith "\n" <<< Map.toAscUnfoldable >>> map
  \(Tuple name (DataTypeDef vs dt)) ->
    let
      vars = joinWithIfNE " " show vs
    in show (declKeyword dt) <> " " <> show name <> vars <> " = " <> show dt

type Modules = Map Module ModuleData
type ModuleData =
  { imports :: ImportModules
  , datatypes :: DataTypeDecls
  }
showModuleData :: ModuleData -> String
showModuleData = do
  imports <- showImportModules <<< _.imports
  datatypes <- showDataTypeDecls <<< _.datatypes
  pure (imports <> "\n\n" <> datatypes)


Fix test for foldrDefault (#79)

Fix test for foldrDefault (#79)

* Fix test for foldrDefault

The test labelled "Test foldrDefault" was calling the function to test
fold*l*Default (`testFoldableFoldlDefault`). The test for
foldrDefault (`testFoldableFoldrDefault`) was never called.

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldMap, bifoldrDefault, bifoldlDefault, bifoldMapDefaultR, bifoldMapDefaultL)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Bitraversable (class Bitraversable, bisequenceDefault, bitraverse, bisequence, bitraverseDefault)
import Data.Foldable (class Foldable, find, findMap, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, length, maximum, maximumBy, minimum, minimumBy, null, surroundMap)
import Data.FoldableWithIndex (class FoldableWithIndex, findWithIndex, foldMapWithIndex, foldMapWithIndexDefaultL, foldMapWithIndexDefaultR, foldlWithIndex, foldlWithIndexDefault, foldrWithIndex, foldrWithIndexDefault, surroundMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
import Math (abs)
import Test.Assert (ASSERT, assert)

foreign import arrayFrom1UpTo :: Int -> Array Int

main :: Eff (console :: CONSOLE, assert :: ASSERT) Unit
main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  assert $ foldMapDefaultL (\x -> [x]) [1, 2] == [1, 2]

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldrDefault 20

  log "Test traversableArray instance"
  testTraversableArrayWith 20

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "Test foldableWithIndexArray instance"
  testFoldableWithIndexArrayWith 20

  log "Test foldableWithIndexArray instance is stack safe"
  testFoldableWithIndexArrayWith 20000

  log "Test FoldableWithIndex laws for array instance"
  testFoldableWithIndexLawsOn
    ["a", "b", "c"]
    (\i x -> [Tuple i x])
    (\x -> [x])

  log "Test traversableArrayWithIndex instance"
  testTraversableWithIndexArrayWith 20

  log "Test Bifoldable on `inclusive or`"
  testBifoldableIOrWith id 10 100 42

  log "Test bifoldMapDefaultL"
  testBifoldableIOrWith BFML 10 100 42

  log "Test bifoldMapDefaultR"
  testBifoldableIOrWith BFMR 10 100 42

  log "Test bifoldlDefault"
  testBifoldableIOrWith BFLD 10 100 42

  log "Test bifoldrDefault"
  testBifoldableIOrWith BFRD 10 100 42

  log "Test Bitraversable on `inclusive or`"
  testBitraversableIOrWith id

  log "Test bitraverseDefault"
  testBitraversableIOrWith BTD

  log "Test bisequenceDefault"
  testBitraversableIOrWith BSD

  log "Test find"
  assert $ find (_ == 10) [1, 5, 10] == Just 10
  assert $ find (\x -> x `mod` 2 == 0) [1, 4, 10] == Just 4

  log "Test findWithIndex"
  assert $ findWithIndex (\i x -> i == 2 && x `mod` 2 == 0) [1, 2, 4, 6] == Just 4

  log "Test findMap" *> do
    let pred x = if x > 5 then Just (x * 100) else Nothing
    assert $ findMap pred [1, 5, 10, 20] == Just 1000

  log "Test maximum"
  assert $ maximum (arrayFrom1UpTo 10) == Just 10

  log "Test maximumBy"
  assert $
    maximumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-10.0)

  log "Test minimum"
  assert $ minimum (arrayFrom1UpTo 10) == Just 1

  log "Test minimumBy"
  assert $
    minimumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-1.0)

  log "Test null"
  assert $ null Nothing == true
  assert $ null (Just 1) == false
  assert $ null [] == true
  assert $ null [0] == false
  assert $ null [0,1] == false

  log "Test length"
  assert $ length Nothing == 0
  assert $ length (Just 1) == 1
  assert $ length [] == 0
  assert $ length [1] == 1
  assert $ length [1, 2] == 2

  log "Test surroundMap"
  assert $ "*" == surroundMap "*" show ([] :: Array Int)
  assert $ "*1*" == surroundMap "*" show [1]
  assert $ "*1*2*" == surroundMap "*" show [1, 2]
  assert $ "*1*2*3*" == surroundMap "*" show [1, 2, 3]

  log "Test surroundMapWithIndex"
  assert $ "*" == surroundMapWithIndex "*" (\i x -> show i <> x) []
  assert $ "*0a*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
  assert $ "*0a*1b*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
  assert $ "*0a*1b*2c*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]

  log "All done!"

testFoldableFWith
  :: forall f e
   . Foldable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableFWith f n = do
  let dat = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 dat == expectedSum
  assert $ foldl (+) 0 dat == expectedSum
  assert $ foldMap Additive dat == Additive expectedSum

testFoldableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testFoldableWithIndexFWith
  :: forall f e
   . FoldableWithIndex Int f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexFWith f n = do
  let dat = f n
  -- expectedSum = \Sum_{1 <= i <= n} i * i
  let expectedSum = n * (n + 1) * (2 * n + 1) / 6

  assert $ foldrWithIndex (\i x y -> (i + 1) * x + y) 0 dat == expectedSum
  assert $ foldlWithIndex (\i y x -> y + (i + 1) * x) 0 dat == expectedSum
  assert $ foldMapWithIndex (\i x -> Additive $ (i + 1) * x) dat == Additive expectedSum

testFoldableWithIndexArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableWithIndexArrayWith = testFoldableWithIndexFWith arrayFrom1UpTo

data Tuple a b = Tuple a b
derive instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b)

-- test whether foldable laws hold, using foldMap and ifoldMap
testFoldableWithIndexLawsOn
  :: forall f i a m n e
   . FoldableWithIndex i f
  => FunctorWithIndex i f
  => Monoid m
  => Monoid n
  => Eq m
  => Eq n
  => f a
  -> (i -> a -> m)
  -> (a -> n)
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexLawsOn c f g = do
  -- compatibility with FunctorWithIndex (not strictly necessary for a valid
  -- instance, but it's likely an error if this does not hold)
  assert $ foldMapWithIndex f c == fold (mapWithIndex f c)

  -- Compatiblity with Foldable
  assert $ foldMap g c == foldMapWithIndex (const g) c

  -- FoldableWithIndex laws
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultL f c
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultR f c

  -- These follow from the above laws, but they test whether ifoldlDefault and
  -- ifoldrDefault have been specified correctly.
  assert $ foldMapWithIndex f c == foldlWithIndexDefault (\i y x -> y <> f i x) mempty c
  assert $ foldMapWithIndex f c == foldrWithIndexDefault (\i x y -> f i x <> y) mempty c

testTraversableFWith
  :: forall f e
   . Traversable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableFWith f n = do
  let dat = f n

  assert $ traverse Just dat == Just dat
  assert $ traverse pure dat == [dat]
  assert $ traverse (\x -> if x < 10 then Just x else Nothing) dat == Nothing
  assert $ sequence (map Just dat) == traverse Just dat

testTraversableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

testTraversableWithIndexFWith
  :: forall f e
   . TraversableWithIndex Int f
  => Eq (f (Tuple Int Int))
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableWithIndexFWith f n = do
  let dat = f n

  assert $ traverseWithIndex (\i -> Just <<< Tuple i) dat == Just (mapWithIndex Tuple dat)
  assert $ traverseWithIndex (const Just) dat == traverse Just dat
  assert $ traverseWithIndex (\i -> pure <<< Tuple i) dat == [mapWithIndex Tuple dat]
  assert $
    traverseWithIndex (const pure :: Int -> Int -> Array Int) dat ==
    traverse pure dat

testTraversableWithIndexArrayWith
  :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableWithIndexArrayWith = testTraversableWithIndexFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)

testFoldableFoldMapDefaultR :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)

testFoldableFoldlDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldlDefault = testFoldableFWith (FLD <<< arrayFrom1UpTo)

testFoldableFoldrDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldrDefault = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)

testSequenceDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)

-- structure for testing bifoldable, picked `inclusive or` as it has both products and sums

data IOr l r = Both l r | Fst l | Snd r

instance eqIOr :: (Eq l, Eq r) => Eq (IOr l r) where
  eq (Both lFst lSnd) (Both rFst rSnd) = (lFst == rFst) && (lSnd == rSnd)
  eq (Fst l)          (Fst r)          = l == r
  eq (Snd l)          (Snd r)          = l == r
  eq _                _                = false

instance bifoldableIOr :: Bifoldable IOr where
  bifoldr l r u (Both fst snd) = l fst (r snd u)
  bifoldr l r u (Fst fst)      = l fst u
  bifoldr l r u (Snd snd)      = r snd u

  bifoldl l r u (Both fst snd) = r (l u fst) snd
  bifoldl l r u (Fst fst)      = l u fst
  bifoldl l r u (Snd snd)      = r u snd

  bifoldMap l r (Both fst snd) = l fst <> r snd
  bifoldMap l r (Fst fst)      = l fst
  bifoldMap l r (Snd snd)      = r snd

instance bifunctorIOr :: Bifunctor IOr where
  bimap f g (Both fst snd) = Both (f fst) (g snd)
  bimap f g (Fst fst)      = Fst (f fst)
  bimap f g (Snd snd)      = Snd (g snd)

instance bitraversableIOr :: Bitraversable IOr where
  bitraverse f g (Both fst snd) = Both <$> f fst <*> g snd
  bitraverse f g (Fst fst)      = Fst <$> f fst
  bitraverse f g (Snd snd)      = Snd <$> g snd

  bisequence (Both fst snd) = Both <$> fst <*> snd
  bisequence (Fst fst)      = Fst <$> fst
  bisequence (Snd snd)      = Snd <$> snd

testBifoldableIOrWith
  :: forall t e
   . Bifoldable t
  => Eq (t Int Int)
  => (forall l r. IOr l r -> t l r)
  -> Int
  -> Int
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testBifoldableIOrWith lift fst snd u = do
  assert $ bifoldr (+) (*) u (lift $ Both fst snd) == fst + (snd * u)
  assert $ bifoldr (+) (*) u (lift $ Fst fst)      == fst + u
  assert $ bifoldr (+) (*) u (lift $ Snd snd)      == snd * u

  assert $ bifoldl (+) (*) u (lift $ Both fst snd) == (u + fst) * snd
  assert $ bifoldl (+) (*) u (lift $ Fst fst)      == u + fst
  assert $ bifoldl (+) (*) u (lift $ Snd snd)      == u * snd

  assert $ bifoldMap Additive Additive (lift $ Both fst snd) == Additive (fst + snd)
  assert $ bifoldMap Additive Additive (lift $ Fst fst)      == Additive fst
  assert $ bifoldMap Additive Additive (lift $ Snd snd)      == Additive snd

testBitraversableIOrWith
  :: forall t e
   . Bitraversable t
  => Eq (t Boolean Boolean)
  => (forall l r. IOr l r -> t l r)
  -> Eff (assert :: ASSERT | e) Unit
testBitraversableIOrWith lift = do
  let just a = Just (lift a)
  assert $ bisequence (lift (Both (Just true) (Just false))) == just (Both true false)
  assert $ bisequence (lift (Fst (Just true)))               == just (Fst true  :: IOr Boolean Boolean)
  assert $ bisequence (lift (Snd (Just false)))              == just (Snd false :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Both true false))     == just (Both true false)
  assert $ bitraverse Just Just (lift (Fst true))            == just (Fst true  :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Snd false))           == just (Snd false :: IOr Boolean Boolean)

-- structures for testing default `Bifoldable` implementations

newtype BifoldMapDefaultL l r = BFML (IOr l r)
newtype BifoldMapDefaultR l r = BFMR (IOr l r)
newtype BifoldlDefault    l r = BFLD (IOr l r)
newtype BifoldrDefault    l r = BFRD (IOr l r)

instance eqBFML :: (Eq l, Eq r) => Eq (BifoldMapDefaultL l r) where eq (BFML l) (BFML r) = l == r
instance eqBFMR :: (Eq l, Eq r) => Eq (BifoldMapDefaultR l r) where eq (BFMR l) (BFMR r) = l == r
instance eqBFLD :: (Eq l, Eq r) => Eq (BifoldlDefault l r)    where eq (BFLD l) (BFLD r) = l == r
instance eqBFRD :: (Eq l, Eq r) => Eq (BifoldrDefault l r)    where eq (BFRD l) (BFRD r) = l == r

instance bifoldableBFML :: Bifoldable BifoldMapDefaultL where
  bifoldMap f g m        = bifoldMapDefaultL f g m
  bifoldr f g u (BFML m) = bifoldr f g u m
  bifoldl f g u (BFML m) = bifoldl f g u m

instance bifoldableBFMR :: Bifoldable BifoldMapDefaultR where
  bifoldMap f g m        = bifoldMapDefaultR f g m
  bifoldr f g u (BFMR m) = bifoldr f g u m
  bifoldl f g u (BFMR m) = bifoldl f g u m

instance bifoldableBFLD :: Bifoldable BifoldlDefault where
  bifoldMap f g (BFLD m) = bifoldMap f g m
  bifoldr f g u (BFLD m) = bifoldr f g u m
  bifoldl f g u m        = bifoldlDefault f g u m

instance bifoldableBFRD :: Bifoldable BifoldrDefault where
  bifoldMap f g (BFRD m) = bifoldMap f g m
  bifoldr f g u m        = bifoldrDefault f g u m
  bifoldl f g u (BFRD m) = bifoldl f g u m

-- structures for testing default `Bitraversable` implementations

newtype BitraverseDefault l r = BTD (IOr l r)
newtype BisequenceDefault l r = BSD (IOr l r)

instance eqBTD :: (Eq l, Eq r) => Eq (BitraverseDefault l r) where eq (BTD l) (BTD r) = l == r
instance eqBSD :: (Eq l, Eq r) => Eq (BisequenceDefault l r) where eq (BSD l) (BSD r) = l == r

instance bifunctorBTD :: Bifunctor BitraverseDefault where bimap f g (BTD m) = BTD (bimap f g m)
instance bifunctorBSD :: Bifunctor BisequenceDefault where bimap f g (BSD m) = BSD (bimap f g m)

instance bifoldableBTD :: Bifoldable BitraverseDefault where
  bifoldMap f g (BTD m) = bifoldMap f g m
  bifoldr f g u (BTD m) = bifoldr f g u m
  bifoldl f g u (BTD m) = bifoldl f g u m

instance bifoldableBSD :: Bifoldable BisequenceDefault where
  bifoldMap f g (BSD m) = bifoldMap f g m
  bifoldr f g u (BSD m) = bifoldr f g u m
  bifoldl f g u (BSD m) = bifoldl f g u m

instance bitraversableBTD :: Bitraversable BitraverseDefault where
  bitraverse f g     = bitraverseDefault f g
  bisequence (BTD m) = map BTD (bisequence m)

instance bitraversableBSD :: Bitraversable BisequenceDefault where
  bitraverse f g (BSD m) = map BSD (bitraverse f g m)
  bisequence m           = bisequenceDefault m

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldMap, bifoldrDefault, bifoldlDefault, bifoldMapDefaultR, bifoldMapDefaultL)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Bitraversable (class Bitraversable, bisequenceDefault, bitraverse, bisequence, bitraverseDefault)
import Data.Foldable (class Foldable, find, findMap, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, length, maximum, maximumBy, minimum, minimumBy, null, surroundMap)
import Data.FoldableWithIndex (class FoldableWithIndex, findWithIndex, foldMapWithIndex, foldMapWithIndexDefaultL, foldMapWithIndexDefaultR, foldlWithIndex, foldlWithIndexDefault, foldrWithIndex, foldrWithIndexDefault, surroundMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
import Math (abs)
import Test.Assert (ASSERT, assert)

foreign import arrayFrom1UpTo :: Int -> Array Int

main :: Eff (console :: CONSOLE, assert :: ASSERT) Unit
main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  assert $ foldMapDefaultL (\x -> [x]) [1, 2] == [1, 2]

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldlDefault 20

  log "Test traversableArray instance"
  testTraversableArrayWith 20

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "Test foldableWithIndexArray instance"
  testFoldableWithIndexArrayWith 20

  log "Test foldableWithIndexArray instance is stack safe"
  testFoldableWithIndexArrayWith 20000

  log "Test FoldableWithIndex laws for array instance"
  testFoldableWithIndexLawsOn
    ["a", "b", "c"]
    (\i x -> [Tuple i x])
    (\x -> [x])

  log "Test traversableArrayWithIndex instance"
  testTraversableWithIndexArrayWith 20

  log "Test Bifoldable on `inclusive or`"
  testBifoldableIOrWith id 10 100 42

  log "Test bifoldMapDefaultL"
  testBifoldableIOrWith BFML 10 100 42

  log "Test bifoldMapDefaultR"
  testBifoldableIOrWith BFMR 10 100 42

  log "Test bifoldlDefault"
  testBifoldableIOrWith BFLD 10 100 42

  log "Test bifoldrDefault"
  testBifoldableIOrWith BFRD 10 100 42

  log "Test Bitraversable on `inclusive or`"
  testBitraversableIOrWith id

  log "Test bitraverseDefault"
  testBitraversableIOrWith BTD

  log "Test bisequenceDefault"
  testBitraversableIOrWith BSD

  log "Test find"
  assert $ find (_ == 10) [1, 5, 10] == Just 10
  assert $ find (\x -> x `mod` 2 == 0) [1, 4, 10] == Just 4

  log "Test findWithIndex"
  assert $ findWithIndex (\i x -> i == 2 && x `mod` 2 == 0) [1, 2, 4, 6] == Just 4

  log "Test findMap" *> do
    let pred x = if x > 5 then Just (x * 100) else Nothing
    assert $ findMap pred [1, 5, 10, 20] == Just 1000

  log "Test maximum"
  assert $ maximum (arrayFrom1UpTo 10) == Just 10

  log "Test maximumBy"
  assert $
    maximumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-10.0)

  log "Test minimum"
  assert $ minimum (arrayFrom1UpTo 10) == Just 1

  log "Test minimumBy"
  assert $
    minimumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-1.0)

  log "Test null"
  assert $ null Nothing == true
  assert $ null (Just 1) == false
  assert $ null [] == true
  assert $ null [0] == false
  assert $ null [0,1] == false

  log "Test length"
  assert $ length Nothing == 0
  assert $ length (Just 1) == 1
  assert $ length [] == 0
  assert $ length [1] == 1
  assert $ length [1, 2] == 2

  log "Test surroundMap"
  assert $ "*" == surroundMap "*" show ([] :: Array Int)
  assert $ "*1*" == surroundMap "*" show [1]
  assert $ "*1*2*" == surroundMap "*" show [1, 2]
  assert $ "*1*2*3*" == surroundMap "*" show [1, 2, 3]

  log "Test surroundMapWithIndex"
  assert $ "*" == surroundMapWithIndex "*" (\i x -> show i <> x) []
  assert $ "*0a*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
  assert $ "*0a*1b*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
  assert $ "*0a*1b*2c*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]

  log "All done!"

testFoldableFWith
  :: forall f e
   . Foldable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableFWith f n = do
  let dat = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 dat == expectedSum
  assert $ foldl (+) 0 dat == expectedSum
  assert $ foldMap Additive dat == Additive expectedSum

testFoldableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testFoldableWithIndexFWith
  :: forall f e
   . FoldableWithIndex Int f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexFWith f n = do
  let dat = f n
  -- expectedSum = \Sum_{1 <= i <= n} i * i
  let expectedSum = n * (n + 1) * (2 * n + 1) / 6

  assert $ foldrWithIndex (\i x y -> (i + 1) * x + y) 0 dat == expectedSum
  assert $ foldlWithIndex (\i y x -> y + (i + 1) * x) 0 dat == expectedSum
  assert $ foldMapWithIndex (\i x -> Additive $ (i + 1) * x) dat == Additive expectedSum

testFoldableWithIndexArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableWithIndexArrayWith = testFoldableWithIndexFWith arrayFrom1UpTo

data Tuple a b = Tuple a b
derive instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b)

-- test whether foldable laws hold, using foldMap and ifoldMap
testFoldableWithIndexLawsOn
  :: forall f i a m n e
   . FoldableWithIndex i f
  => FunctorWithIndex i f
  => Monoid m
  => Monoid n
  => Eq m
  => Eq n
  => f a
  -> (i -> a -> m)
  -> (a -> n)
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexLawsOn c f g = do
  -- compatibility with FunctorWithIndex (not strictly necessary for a valid
  -- instance, but it's likely an error if this does not hold)
  assert $ foldMapWithIndex f c == fold (mapWithIndex f c)

  -- Compatiblity with Foldable
  assert $ foldMap g c == foldMapWithIndex (const g) c

  -- FoldableWithIndex laws
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultL f c
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultR f c

  -- These follow from the above laws, but they test whether ifoldlDefault and
  -- ifoldrDefault have been specified correctly.
  assert $ foldMapWithIndex f c == foldlWithIndexDefault (\i y x -> y <> f i x) mempty c
  assert $ foldMapWithIndex f c == foldrWithIndexDefault (\i x y -> f i x <> y) mempty c

testTraversableFWith
  :: forall f e
   . Traversable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableFWith f n = do
  let dat = f n

  assert $ traverse Just dat == Just dat
  assert $ traverse pure dat == [dat]
  assert $ traverse (\x -> if x < 10 then Just x else Nothing) dat == Nothing
  assert $ sequence (map Just dat) == traverse Just dat

testTraversableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

testTraversableWithIndexFWith
  :: forall f e
   . TraversableWithIndex Int f
  => Eq (f (Tuple Int Int))
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableWithIndexFWith f n = do
  let dat = f n

  assert $ traverseWithIndex (\i -> Just <<< Tuple i) dat == Just (mapWithIndex Tuple dat)
  assert $ traverseWithIndex (const Just) dat == traverse Just dat
  assert $ traverseWithIndex (\i -> pure <<< Tuple i) dat == [mapWithIndex Tuple dat]
  assert $
    traverseWithIndex (const pure :: Int -> Int -> Array Int) dat ==
    traverse pure dat

testTraversableWithIndexArrayWith
  :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableWithIndexArrayWith = testTraversableWithIndexFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)

testFoldableFoldMapDefaultR :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)

testFoldableFoldlDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldlDefault = testFoldableFWith (FLD <<< arrayFrom1UpTo)

testFoldableFoldrDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldrDefault = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)

testSequenceDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)

-- structure for testing bifoldable, picked `inclusive or` as it has both products and sums

data IOr l r = Both l r | Fst l | Snd r

instance eqIOr :: (Eq l, Eq r) => Eq (IOr l r) where
  eq (Both lFst lSnd) (Both rFst rSnd) = (lFst == rFst) && (lSnd == rSnd)
  eq (Fst l)          (Fst r)          = l == r
  eq (Snd l)          (Snd r)          = l == r
  eq _                _                = false

instance bifoldableIOr :: Bifoldable IOr where
  bifoldr l r u (Both fst snd) = l fst (r snd u)
  bifoldr l r u (Fst fst)      = l fst u
  bifoldr l r u (Snd snd)      = r snd u

  bifoldl l r u (Both fst snd) = r (l u fst) snd
  bifoldl l r u (Fst fst)      = l u fst
  bifoldl l r u (Snd snd)      = r u snd

  bifoldMap l r (Both fst snd) = l fst <> r snd
  bifoldMap l r (Fst fst)      = l fst
  bifoldMap l r (Snd snd)      = r snd

instance bifunctorIOr :: Bifunctor IOr where
  bimap f g (Both fst snd) = Both (f fst) (g snd)
  bimap f g (Fst fst)      = Fst (f fst)
  bimap f g (Snd snd)      = Snd (g snd)

instance bitraversableIOr :: Bitraversable IOr where
  bitraverse f g (Both fst snd) = Both <$> f fst <*> g snd
  bitraverse f g (Fst fst)      = Fst <$> f fst
  bitraverse f g (Snd snd)      = Snd <$> g snd

  bisequence (Both fst snd) = Both <$> fst <*> snd
  bisequence (Fst fst)      = Fst <$> fst
  bisequence (Snd snd)      = Snd <$> snd

testBifoldableIOrWith
  :: forall t e
   . Bifoldable t
  => Eq (t Int Int)
  => (forall l r. IOr l r -> t l r)
  -> Int
  -> Int
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testBifoldableIOrWith lift fst snd u = do
  assert $ bifoldr (+) (*) u (lift $ Both fst snd) == fst + (snd * u)
  assert $ bifoldr (+) (*) u (lift $ Fst fst)      == fst + u
  assert $ bifoldr (+) (*) u (lift $ Snd snd)      == snd * u

  assert $ bifoldl (+) (*) u (lift $ Both fst snd) == (u + fst) * snd
  assert $ bifoldl (+) (*) u (lift $ Fst fst)      == u + fst
  assert $ bifoldl (+) (*) u (lift $ Snd snd)      == u * snd

  assert $ bifoldMap Additive Additive (lift $ Both fst snd) == Additive (fst + snd)
  assert $ bifoldMap Additive Additive (lift $ Fst fst)      == Additive fst
  assert $ bifoldMap Additive Additive (lift $ Snd snd)      == Additive snd

testBitraversableIOrWith
  :: forall t e
   . Bitraversable t
  => Eq (t Boolean Boolean)
  => (forall l r. IOr l r -> t l r)
  -> Eff (assert :: ASSERT | e) Unit
testBitraversableIOrWith lift = do
  let just a = Just (lift a)
  assert $ bisequence (lift (Both (Just true) (Just false))) == just (Both true false)
  assert $ bisequence (lift (Fst (Just true)))               == just (Fst true  :: IOr Boolean Boolean)
  assert $ bisequence (lift (Snd (Just false)))              == just (Snd false :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Both true false))     == just (Both true false)
  assert $ bitraverse Just Just (lift (Fst true))            == just (Fst true  :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Snd false))           == just (Snd false :: IOr Boolean Boolean)

-- structures for testing default `Bifoldable` implementations

newtype BifoldMapDefaultL l r = BFML (IOr l r)
newtype BifoldMapDefaultR l r = BFMR (IOr l r)
newtype BifoldlDefault    l r = BFLD (IOr l r)
newtype BifoldrDefault    l r = BFRD (IOr l r)

instance eqBFML :: (Eq l, Eq r) => Eq (BifoldMapDefaultL l r) where eq (BFML l) (BFML r) = l == r
instance eqBFMR :: (Eq l, Eq r) => Eq (BifoldMapDefaultR l r) where eq (BFMR l) (BFMR r) = l == r
instance eqBFLD :: (Eq l, Eq r) => Eq (BifoldlDefault l r)    where eq (BFLD l) (BFLD r) = l == r
instance eqBFRD :: (Eq l, Eq r) => Eq (BifoldrDefault l r)    where eq (BFRD l) (BFRD r) = l == r

instance bifoldableBFML :: Bifoldable BifoldMapDefaultL where
  bifoldMap f g m        = bifoldMapDefaultL f g m
  bifoldr f g u (BFML m) = bifoldr f g u m
  bifoldl f g u (BFML m) = bifoldl f g u m

instance bifoldableBFMR :: Bifoldable BifoldMapDefaultR where
  bifoldMap f g m        = bifoldMapDefaultR f g m
  bifoldr f g u (BFMR m) = bifoldr f g u m
  bifoldl f g u (BFMR m) = bifoldl f g u m

instance bifoldableBFLD :: Bifoldable BifoldlDefault where
  bifoldMap f g (BFLD m) = bifoldMap f g m
  bifoldr f g u (BFLD m) = bifoldr f g u m
  bifoldl f g u m        = bifoldlDefault f g u m

instance bifoldableBFRD :: Bifoldable BifoldrDefault where
  bifoldMap f g (BFRD m) = bifoldMap f g m
  bifoldr f g u m        = bifoldrDefault f g u m
  bifoldl f g u (BFRD m) = bifoldl f g u m

-- structures for testing default `Bitraversable` implementations

newtype BitraverseDefault l r = BTD (IOr l r)
newtype BisequenceDefault l r = BSD (IOr l r)

instance eqBTD :: (Eq l, Eq r) => Eq (BitraverseDefault l r) where eq (BTD l) (BTD r) = l == r
instance eqBSD :: (Eq l, Eq r) => Eq (BisequenceDefault l r) where eq (BSD l) (BSD r) = l == r

instance bifunctorBTD :: Bifunctor BitraverseDefault where bimap f g (BTD m) = BTD (bimap f g m)
instance bifunctorBSD :: Bifunctor BisequenceDefault where bimap f g (BSD m) = BSD (bimap f g m)

instance bifoldableBTD :: Bifoldable BitraverseDefault where
  bifoldMap f g (BTD m) = bifoldMap f g m
  bifoldr f g u (BTD m) = bifoldr f g u m
  bifoldl f g u (BTD m) = bifoldl f g u m

instance bifoldableBSD :: Bifoldable BisequenceDefault where
  bifoldMap f g (BSD m) = bifoldMap f g m
  bifoldr f g u (BSD m) = bifoldr f g u m
  bifoldl f g u (BSD m) = bifoldl f g u m

instance bitraversableBTD :: Bitraversable BitraverseDefault where
  bitraverse f g     = bitraverseDefault f g
  bisequence (BTD m) = map BTD (bisequence m)

instance bitraversableBSD :: Bitraversable BisequenceDefault where
  bitraverse f g (BSD m) = map BSD (bitraverse f g m)
  bisequence m           = bisequenceDefault m