Clean up a few details

Clean up a few details

module Types where

import Prelude

import Control.Apply (lift2)
import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
import Control.Monad.State (State, evalState, gets, modify)
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.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.HeytingAlgebra (ff, tt)
import Data.Identity (Identity(..))
import Data.Map (Map)
import Data.Map (fromFoldable, toAscUnfoldable, singleton, insert) as Map
import Data.Maybe (Maybe(..), fromMaybe)
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) as StrMap
import Data.String (Pattern(..), Replacement(..), drop, joinWith, length, replaceAll, take)
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..), fst, uncurry)
import Matryoshka (Algebra, GAlgebra, cata, para)
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 (SProxy :: SProxy "app")

aTypeFunction :: ATypeV -> ATypeV -> ATypeV
aTypeFunction = aTypePair (SProxy :: SProxy "function")

aTypeName :: Qualified Proper -> ATypeV
aTypeName = aTypeConst (SProxy :: SProxy "name")

aTypeVar :: Ident -> ATypeV
aTypeVar = aTypeConst (SProxy :: SProxy "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 "Module")
    `aTypeApp` (atnunqp "Meh" `aTypeFunction` atnunqp "Eh"))

otherTest :: ATypeV
otherTest = chainl 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 (cata simpleShow) z <> ", " <> cata simpleShow h <> ")"
  Tuple Nothing h -> cata simpleShow h

testTypeC :: ATypeVC
testTypeC = evalState (cata showTagged1 testType) mempty

testTypeCS :: String
testTypeCS = cofrecurse testTypeC

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

testTypeLC' :: Tuple ZipperVC ATypeVC
testTypeLC' = extract1C' rightC testTypeC

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

testPatchSameR :: ATypeVC
testPatchSameR = uncurry patch $ map forget testTypeLC'

testPatchSameL :: ATypeVC
testPatchSameL = uncurry patch $ map forget $ extract1C' leftC testTypeC

testPatchExplodeR :: ATypeVC
testPatchExplodeR = patch (fst testTypeLC') otherTest

testPatchExplodeL :: ATypeVC
testPatchExplodeL = patch (fst $ extract1C' leftC testTypeC) otherTest

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 = show (head v) <> " :< " <>
  ( VF.case_
  # VF.on _var (unwrap >>> show)
  # VF.on _name (unwrap >>> show)
  # VF.on _function (\(Pair l r) -> "function" <>
      badindent ("\n" <> cofrecurse l <> "\n" <> cofrecurse r))
  # VF.on _app (\(Pair l r) -> "app" <>
      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 <> ")"
wrapIf :: Boolean -> String -> String
wrapIf true = wrap
wrapIf false = id
wrapIf' :: String -> Boolean -> String
wrapIf' = flip wrapIf
wrapIfl :: forall a. (a -> Boolean) -> (a -> String) -> (a -> String)
wrapIfl = lift2 wrapIf

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 <> case ts of
      [] -> ""
      _ ->
        " " <> joinWith " "
          (wrapIfl (isTypeFunction || isTypeApp) showAType <$> 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)

{-
downZipperVC :: ATypeVC -> ATypeVF (Tuple ZipperVC ATypeVC)
downZipperVC v =
  let
    h = head v :: Tag
    t = tail v :: ATypeVF (ATypeVC)
    dot = ?dot
  in h :< dot
-}

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 a da => Diff1 StrMap DStrMap where
  upF (ZF eh x) = case fromDF eh of
    DStrMap key dx rest ->
      StrMap.insert key (upF (ZF (toDF dx) x)) 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)
  )

joinPair :: String -> Pair String -> String
joinPair m (Pair l r) = l <> m <> r

simpleShow :: Algebra ATypeVF String
simpleShow = VF.match
  { name: unwrap >>> show
  , var: unwrap >>> show
  , function: joinPair " -> "
  , app: joinPair " "
  --, row: const "()"
  }

type Tag = Tuple (Additive Int) String
type Tagged f = Cofree f Tag
type Tagging a = State String a

len :: Tag -> Additive Int
len = Additive <<< length <<< content

start :: Tag -> Additive Int
start (Tuple i _) = i

end :: Tag -> Additive Int
end = start <> len

content :: Tag -> String
content (Tuple _ s) = s

tag :: Tagging (ATypeVF (Tagged ATypeVF)) -> Tagging (Tagged ATypeVF)
tag r = do
  offset <- gets (Additive <<< length)
  res <- r
  added <- gets (drop (unwrap offset))
  pure (Tuple offset added :< res)

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

simple :: ATypeVF Void -> String -> Tagging (Tagged ATypeVF)
simple v s = tag do
  literal s
  pure (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 -> Tagging (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

showTagged1 :: Algebra ATypeVF (Tagging (Tagged ATypeVF))
showTagged1 = VF.match
  { name: simpleShowConst (SProxy :: SProxy "name")
  , var: simpleShowConst (SProxy :: SProxy "var")
  , function: \(Pair l r) -> tag do
      a <- l
      literal " -> "
      b <- r
      pure (VF.inj (SProxy :: SProxy "function") (Pair a b))
  , app: \(Pair l r) -> tag do
      a <- l
      literal " "
      b <- r
      pure (VF.inj (SProxy :: SProxy "app") (Pair a b))
  --, row: \meh -> tag do
      --literal "meh"
      --pure (VF.inj (SProxy :: SProxy "row") meh)
  }

evalFrom :: Additive Int -> Tagging (Tagged ATypeVF) -> Tagged ATypeVF
evalFrom st producer =
  lmap (_ <> st) <$> evalState producer ""

patch :: ZipperVC -> ATypeV -> ATypeVC
patch positioned replacement =
  let
    caput = head positioned
    st = start caput
    sz = len caput
    old = content caput
  in case tail positioned of
    Compose Nothing ->
      evalFrom st $ cata showTagged1 replacement
    Compose (Just inside) ->
      let
        next ::
          forall sym bleh.
            IsSymbol sym =>
            RowCons sym (FProxy Pair) bleh ATypeVR =>
          SProxy sym ->
          DPair' (Tagged ATypeVF) (Tagged (ZipperVF' (Tagged ATypeVF))) ->
          Tagged ATypeVF
        next k (DPairL' da a) =
          let
            updated = patch da replacement
            Tuple diff spliced = patch1 old (head da) (content (head updated))
          in (Tuple st spliced :< VF.inj k (Pair updated $ patchAfter diff a))
        next k (DPairR' a da) =
          let
            updated = patch da replacement
            Tuple diff spliced = patch1 old (head da) (content (head updated))
          in (Tuple st spliced :< VF.inj k (Pair a updated))
      in inside # VF.match
        { function: next (SProxy :: SProxy "function")
        , app: next (SProxy :: SProxy "app")
        }

patch1 :: String -> Tag -> String -> Tag
patch1 within old new =
  let
    diff = Additive $ length new - unwrap (len old)
    before = take (unwrap (start old)) within
    after = drop (unwrap (end old)) within
  in Tuple diff (before <> new <> after)

patchAfter :: Additive Int -> Tagged ATypeVF -> Tagged ATypeVF
patchAfter diff = (lmap (_ <> diff) <$> _)

showAType :: ATypeV -> String
showAType one = para showInner one
  where
    showInner :: GAlgebra (Tuple ATypeV) ATypeVF String
    showInner =
      VF.match
        { name: unwrap >>> show
        , var: unwrap >>> show
        , function:
            \(Pair (Tuple a l) (Tuple b r)) ->
              let left = wrapIf' l $ isTypeFunction a
              in left <> " -> " <> r
        , app:
            \(Pair (Tuple f l) (Tuple a r)) ->
              let
                left = wrapIf' l (isTypeFunction f)
                right = wrapIf' r (isTypeApp a || isTypeFunction a)
              in left <> " " <> right
        --, row:
            --case _ of
              --Product (Tuple m Nothing) ->
                --"( " <> showFields m <> " )"
              --Product (Tuple m (Just (Tuple _ a))) ->
                --"( " <> showFields m <> " | " <> a <> " )"
        }

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

is ::
  forall sym f bleh rows a.
    IsSymbol sym =>
    RowCons sym (FProxy f) bleh rows =>
  SProxy sym -> VariantF rows a -> Boolean
is k = VF.on k tt $ VF.default ff

isTypeFunction :: ATypeV -> Boolean
isTypeFunction = unroll >>> is (SProxy :: SProxy "function")
isTypeApp :: ATypeV -> Boolean
isTypeApp = unroll >>> is (SProxy :: SProxy "app")

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 = case vs of
        [] -> ""
        _ -> " " <> joinWith " " (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, evalState, gets, modify)
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.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.HeytingAlgebra (ff, tt)
import Data.Identity (Identity(..))
import Data.Map (Map)
import Data.Map (fromFoldable, toAscUnfoldable, singleton, insert) as Map
import Data.Maybe (Maybe(..), fromMaybe)
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) as StrMap
import Data.String (Pattern(..), Replacement(..), drop, joinWith, length, replace, replaceAll, take)
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..), fst, uncurry)
import Matryoshka (Algebra, GAlgebra, cata, para)
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 (SProxy :: SProxy "app")

aTypeFunction :: ATypeV -> ATypeV -> ATypeV
aTypeFunction = aTypePair (SProxy :: SProxy "function")

aTypeName :: Qualified Proper -> ATypeV
aTypeName = aTypeConst (SProxy :: SProxy "name")

aTypeVar :: Ident -> ATypeV
aTypeVar = aTypeConst (SProxy :: SProxy "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 = chainr aTypeFunction (Unqualified <<< Proper <$> "Module" :| ["Imports", "ImportModule"])
  `aTypeFunction` ((atnunqp "Map" `aTypeApp` atnunqp "Module")
    `aTypeApp` (atnunqp "Meh" `aTypeFunction` atnunqp "Eh"))

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

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

testTypeC :: ATypeVC
testTypeC = evalState (cata showTagged1 testType) mempty

testTypeCS :: String
testTypeCS = cofrecurse testTypeC

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

testTypeLC' :: Tuple ZipperVC ATypeVC
testTypeLC' = extract1C' rightC mempty testTypeC

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

testPatchSameR :: ATypeVC
testPatchSameR = uncurry patch $ map forget testTypeLC'

testPatchSameL :: ATypeVC
testPatchSameL = uncurry patch $ map forget $ extract1C' leftC mempty testTypeC

testPatchExplodeR :: ATypeVC
testPatchExplodeR = patch (fst testTypeLC') testType

testPatchExplodeL :: ATypeVC
testPatchExplodeL = patch (fst $ extract1C' leftC mempty testTypeC) testType

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 = show (head v) <> " :< " <>
  ( VF.case_
  # VF.on _var (unwrap >>> show)
  # VF.on _name (unwrap >>> show)
  # VF.on _function (\(Pair l r) -> "function" <>
      badindent ("\n" <> cofrecurse l <> "\n" <> cofrecurse r))
  # VF.on _app (\(Pair l r) -> "app" <>
      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 <> ")"
wrapIf :: Boolean -> String -> String
wrapIf true = wrap
wrapIf false = id
wrapIf' :: String -> Boolean -> String
wrapIf' = flip wrapIf
wrapIfl :: forall a. (a -> Boolean) -> (a -> String) -> (a -> String)
wrapIfl = lift2 wrapIf

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 <> case ts of
      [] -> ""
      _ ->
        " " <> joinWith " "
          (wrapIfl (isTypeFunction || isTypeApp) showAType <$> 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 =
  let
    t = unroll v
    dot = 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)
  in dot t

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) ->
  Tag -> ATypeVC -> Tuple ZipperVC ATypeVC
extract1C' choose h 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)

{-
downZipperVC :: ATypeVC -> ATypeVF (Tuple ZipperVC ATypeVC)
downZipperVC v =
  let
    h = head v :: Tag
    t = tail v :: ATypeVF (ATypeVC)
    dot = ?dot
  in h :< dot
-}

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 a da => Diff1 StrMap DStrMap where
  upF (ZF eh x) = case fromDF eh of
    DStrMap key dx rest ->
      StrMap.insert key (upF (ZF (toDF dx) x)) 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)
  )

joinPair :: String -> Pair String -> String
joinPair m (Pair l r) = l <> m <> r

simpleShow :: Algebra ATypeVF String
simpleShow = VF.match
  { name: unwrap >>> show
  , var: unwrap >>> show
  , function: joinPair " -> "
  , app: joinPair " "
  --, row: const "()"
  }

type Tag = Tuple (Additive Int) String
type Tagged f = Cofree f Tag
type Tagging a = State (String) a

len :: Tag -> Additive Int
len = Additive <<< length <<< content

start :: Tag -> Additive Int
start (Tuple i _) = i

end :: Tag -> Additive Int
end = start <> len

content :: Tag -> String
content (Tuple _ s) = s

tag :: Tagging (ATypeVF (Tagged ATypeVF)) -> Tagging (Tagged ATypeVF)
tag r = do
  offset <- gets (Additive <<< length)
  res <- r
  added <- gets (drop (unwrap offset))
  pure (Tuple offset added :< res)

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

simple :: ATypeVF Void -> String -> Tagging (Tagged ATypeVF)
simple v s = tag do
  literal s
  pure (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 -> Tagging (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

showTagged1 :: Algebra ATypeVF (Tagging (Tagged ATypeVF))
showTagged1 = VF.match
  { name: simpleShowConst (SProxy :: SProxy "name")
  , var: simpleShowConst (SProxy :: SProxy "var")
  , function: \(Pair l r) -> tag do
      a <- l
      literal " -> "
      b <- r
      pure (VF.inj (SProxy :: SProxy "function") (Pair a b))
  , app: \(Pair l r) -> tag do
      a <- l
      literal " "
      b <- r
      pure (VF.inj (SProxy :: SProxy "app") (Pair a b))
  --, row: \meh -> tag do
      --literal "meh"
      --pure (VF.inj (SProxy :: SProxy "row") meh)
  }

evalFrom :: Additive Int -> Tagging (Tagged ATypeVF) -> Tagged ATypeVF
evalFrom st producer =
  lmap (_ <> st) <$> evalState producer ""

patch :: ZipperVC -> ATypeV -> ATypeVC
patch positioned replacement =
  let
    caput = head positioned
    st = start caput
    sz = len caput
    old = content caput
  in case tail positioned of
    Compose Nothing ->
      evalFrom st $ cata showTagged1 replacement
    Compose (Just inside) ->
      let
        next ::
          forall sym bleh.
            IsSymbol sym =>
            RowCons sym (FProxy Pair) bleh ATypeVR =>
          SProxy sym ->
          DPair' (Tagged ATypeVF) (Tagged (ZipperVF' (Tagged ATypeVF))) ->
          Tagged ATypeVF
        next k (DPairL' da a) =
          let
            updated = patch da replacement
            Tuple diff spliced = patch1 old (head da) (content (head updated))
          in (Tuple st spliced :< VF.inj k (Pair updated $ patchAfter diff a))
        next k (DPairR' a da) =
          let
            updated = patch da replacement
            Tuple diff spliced = patch1 old (head da) (content (head updated))
          in (Tuple st spliced :< VF.inj k (Pair a updated))
      in inside # VF.match
        { function: next (SProxy :: SProxy "function")
        , app: next (SProxy :: SProxy "app")
        }

patch1 :: String -> Tag -> String -> Tag
patch1 within old new =
  let
    diff = Additive $ length new - unwrap (len old)
    before = take (unwrap (start old)) within
    after = drop (unwrap (end old)) within
  in Tuple diff (before <> new <> after)

patchAfter :: Additive Int -> Tagged ATypeVF -> Tagged ATypeVF
patchAfter diff = (lmap (_ <> diff) <$> _)

showAType :: ATypeV -> String
showAType one = para showInner one
  where
    showInner :: GAlgebra (Tuple ATypeV) ATypeVF String
    showInner =
      VF.match
        { name: unwrap >>> show
        , var: unwrap >>> show
        , function:
            \(Pair (Tuple a l) (Tuple b r)) ->
              let left = wrapIf' l $ isTypeFunction a
              in left <> " -> " <> r
        , app:
            \(Pair (Tuple f l) (Tuple a r)) ->
              let
                left = wrapIf' l (isTypeFunction f)
                right = wrapIf' r (isTypeApp a || isTypeFunction a)
              in left <> " " <> right
        --, row:
            --case _ of
              --Product (Tuple m Nothing) ->
                --"( " <> showFields m <> " )"
              --Product (Tuple m (Just (Tuple _ a))) ->
                --"( " <> showFields m <> " | " <> a <> " )"
        }

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

is ::
  forall sym f bleh rows a.
    IsSymbol sym =>
    RowCons sym (FProxy f) bleh rows =>
  SProxy sym -> VariantF rows a -> Boolean
is k = VF.on k tt $ VF.default ff

isTypeFunction :: ATypeV -> Boolean
isTypeFunction = unroll >>> is (SProxy :: SProxy "function")
isTypeApp :: ATypeV -> Boolean
isTypeApp = unroll >>> is (SProxy :: SProxy "app")

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 = case vs of
        [] -> ""
        _ -> " " <> joinWith " " (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)


updated datetime

updated datetime

module CalendarChart.Main where

import Prelude

import Data.Maybe
import Data.JSON

import CalendarChart.Chart
import CalendarChart.Activities
import CalendarChart.Strava
import CalendarChart.RA
import CalendarChart.Util

import Data.Array(mapMaybe,length,filter,concat,(..),findIndex,modifyAt,(:))
import Data.Date
import Data.Time
import Data.Tuple
import Data.Foldable(for_)

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Class(liftEff)
import Control.Monad.Aff(launchAff,Aff())
import Network.HTTP.Affjax
import Control.Monad.Eff.Console

import qualified Browser.WebStorage as WS

import Data.Either
import Data.Foreign(readString)
import Control.Bind
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Halogen
import Halogen.Signal
import Halogen.Component
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Types as ET
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import Data.Functor (($>))
import Control.Plus (empty)
import qualified Data.Int as I

import Network.RemoteCallback

fetchCont :: (Array Activity -> Eff _ (Unit)) -> Aff _ Unit
fetchCont chartf = do
  strava <- get "data/activities.json"
  let vals = fromMaybe [] $ decode $ strava.response
  ra <- get "data/log.txt"
  pp <- liftEff $ getRAfromText ra.response
  let acts = filter (\(Activity a) -> a.type == Run) $ vals ++ pp
  liftEff $ do
    chartf acts
    callPhantom false

mainWeek :: JSDate -> Eff _ Unit
mainWeek jsd =
  launchAff (fetchCont $ chartWeek dt)
  where
    dt :: Date
    dt = Data.Maybe.Unsafe.fromJust $ fromJSDate jsd

mainMonths = launchAff (fetchCont (chartMonths 1))

chart y = chartMonths y <<< filter (\(Activity a) -> a.type == Run)

stravaTokenKey = "stravaToken"
savedStateKey = "savedState"

downloadStrava :: forall e. Unit -> Aff (console :: CONSOLE, dom :: DOM | e) (Array Activity)
downloadStrava _ = do
  let stravaUrl = "https://www.strava.com/oauth/authorize?client_id=2746&response_type=code&redirect_uri=http://localhost:8123/token_exchange&scope=public&state=mystate&approval_prompt=force"
  cachedToken <- liftEff $ WS.getItem WS.localStorage stravaTokenKey

  case cachedToken of
    Nothing -> do
      liftEff $ log "Downloading Strava"
      let stravaUrl = "https://www.strava.com/oauth/authorize?client_id=2746&response_type=code&redirect_uri=http://localhost:8123/token_exchange&scope=public&state=mystate&approval_prompt=force"
      liftEff $ openWindow stravaUrl "login" "height=600,width=800"
      token <- externalCall "downloadedStrava"
      liftEff $ log $ "Got Strava token: " ++ token
      downloadedStrava token
    Just token -> do
      liftEff $ log "Got cached token"
      downloadedStrava token

downloadedStrava :: forall e. String -> Aff (console :: CONSOLE, dom :: DOM | e) (Array Activity)
downloadedStrava token = do
  liftEff $ log $ "Strava callback complete: " ++ token
  liftEff $ WS.setItem WS.localStorage stravaTokenKey token
  fetchStrava 1 token

fetchStrava :: forall e. Int -> String -> Aff (console :: CONSOLE, dom :: DOM | e) (Array Activity)
fetchStrava page token = do
  liftEff $ log "About to fetch strava data"
  let callback = "PS_FetchStrava_Callback"
  let url = "https://www.strava.com/api/v3/athlete/activities?per_page=200" ++ "&page=" ++ (show page) ++ "&access_token=" ++ token ++ "&callback=" ++ callback
  text <- jsonp callback url
  return $ getStravaFromText text

appendToBody :: forall eff. HTMLElement -> Eff (dom :: DOM | eff) Unit
appendToBody e = document globalWindow >>= (body >=> flip appendChild e)

dataActivities :: forall i. String -> A.Attr i
dataActivities = A.attr $ A.attributeName "data-activities"

data ActivityDetail = RunningAhead | StravaFile | StravaLink
data Activities = Activities ActivityDetail (Array Activity)

data State = State { data:: Array Activities, years:: Int, lastPull:: Maybe Date }

defaultState :: State
defaultState = State { data: [], years: 1, lastPull: Nothing }

instance activityDetailEq :: Eq ActivityDetail where
  eq RunningAhead RunningAhead = true
  eq StravaFile StravaFile = true
  eq StravaLink StravaLink = true
  eq _ _ = false

instance activitiesEq :: Eq Activities where
  eq (Activities d acts) (Activities d' acts') = d == d' && acts == acts'

instance activityDetailToJSON :: ToJSON ActivityDetail where
  toJSON RunningAhead = JString "ra"
  toJSON StravaFile = JString "stravafile"
  toJSON StravaLink = JString "strava"

instance activityDetailFromJSON :: FromJSON ActivityDetail where
  parseJSON (JString "ra") = pure RunningAhead
  parseJSON (JString "stravafile") = pure StravaFile
  parseJSON (JString "strava") = pure StravaLink

instance activitiesToJSON :: ToJSON Activities where
  toJSON (Activities detail acts) = object [ "detail" .= detail, "acts" .= acts ]

instance activitiesFromJSON :: FromJSON Activities where
  parseJSON (JObject o) = do
    detail <- o .: "detail"
    acts <- o .: "acts"
    return $ Activities detail acts

instance stateToJSON :: ToJSON State where
  toJSON (State { data = d, years = y, lastPull = lastPull }) =
    object [ "data" .= d, "years" .= y, "lastPull" .= lastPull ]

instance stateFromJSON :: FromJSON State where
  parseJSON (JObject o) = do
    d <- o .: "data"
    y <- o .: "years"
    lp <- o .: "lastPull"
    return $ State { data: d, years: y, lastPull : lp }

data Input = RaData (Array Activity) | StravaFileData (Array Activity) | Years Int | StravaDownloadData (Array Activity) Date | SavedState State

ui :: State -> Component (E.Event (HalogenEffects _)) Input Input
ui initialState = render <$> stateful initialState updateState
  where
  render :: State -> H.HTML (E.Event (HalogenEffects _) Input)
  render s@(State { data = activities, years = years}) = H.div_
    [ H.input [ A.type_ "file", A.id_ "rafileinput", A.onChange $ \e -> pure (do
        text <- E.async $ getFile e
        liftEff $ log "Got RA data"
        ra <- liftEff $ getRAfromText text
        return $ RaData ra
      ) ] []

    , H.input [ A.type_ "file", A.id_ "stravafileinput", A.onChange $ \e -> pure (do
        text <- E.async $ getFile e
        liftEff $ log "Got Strava data"
        let sa = getStravaFromText text
        return $ StravaFileData sa
      ) ] []

    , H.div [ A.classes [ A.className "header" ] ] [
          H.span [ A.classes [A.className "title"] ] [ H.text "Run Calendar" ]
        , H.span [ A.onClick $ clickFileInput "#rafileinput" ] [ H.text "RA" ]
        , H.span [ A.onClick $ clickFileInput "#stravafileinput", A.classes [A.className "strava"] ] [ H.img [ A.src "strava.svg"] [],  H.text "Strava/local" ]
        , H.span [ A.classes [A.className "strava"], A.onClick $ \_ -> pure (do
              sa <- E.async $ downloadStrava unit
              d <- liftEff $ now
              return $ StravaDownloadData sa d) ]
          [
            H.img [ A.src "strava.svg" ] []
          , H.text "Connect to Strava"
          ]
        , H.text "Years:"
        , H.span_ (yearLink years <$> 1..5 )
        , H.text $ "Data Sources: " ++  show (length activities)
      ]

    , H.div [ dataActivities $ encode s, A.classes [A.className "monthchart", A.className "hcl2"] ] []
    ]

  yearLink years y =
    if y == years then
      H.span [ A.classes [ A.className "year", A.className "selected" ] ] [ H.text $ show y ]
    else
      H.span [ A.onClick $ A.input_ $ Years y, A.classes [ A.className "year" ] ] [ H.text $ show y ]

  clickFileInput :: String -> ET.Event ET.MouseEvent -> E.EventHandler _
  clickFileInput selector _ = pure $ do
      (liftEff $ do
          doc <- document globalWindow
          fileInput <- querySelector selector doc
          case fileInput of
            Just i -> click i
            Nothing -> return unit)
      empty

  getFile e =
    case getElementFile e.target of
      Nothing -> return ""
      Just f -> readAsTextAff (fileReader unit) (fileAsBlob f)

  updateState :: State -> Input -> State
  updateState (State rec @ { data = s }) (RaData a) =
    State rec { data = mergeActs (Activities RunningAhead a) s }
  updateState (State rec @ { data = s }) (StravaFileData a) =
    State rec { data = mergeActs (Activities StravaFile a) s }
  updateState (State rec @ { data = s }) (StravaDownloadData a d) =
    State rec { data = mergeActs (Activities StravaLink a) s, lastPull = Just d }
  updateState (State s) (Years n) = State $ s { years = n }
  updateState (State s) (SavedState ss) = ss
  updateState (ss) _ = ss

mergeActs :: Activities -> Array Activities -> Array Activities
mergeActs (newActs@(Activities d acts)) aa =
  case findIndex (\(Activities d' _) -> d == d') aa of
    Just i -> fromMaybe [] (arr i)
    Nothing -> newActs : aa
  where
    arr :: Int -> Maybe (Array Activities)
    arr i = ((modifyAt i update aa) :: Maybe (Array Activities))
    update (Activities _ acts') = Activities d (acts++acts')

-- mergeActs :: Activities -> Array Activities -> Array Activities
-- mergeActs act [] = [act]
-- mergeActs (Activities d acts) (Activities d' acts' : rest) | d == d' = Activities d (acts++acts') : rest
-- mergeActs x (a : rest) = a : mergeActs x rest

allActivities :: Array Activities -> Array Activity
allActivities acts =
  concat $ toActivities <$> acts
  where
    toActivities (Activities _ acts) = acts

updateChart :: HTMLElement -> Eff (HalogenEffects (d3 :: Graphics.D3.Base.D3, feff :: CalendarChart.Util.FileEffect)) Unit
updateChart elt = do
  divElts <- querySelector ".monthchart" elt
  for_ divElts \divElt -> do
    dat <- getAttribute "data-activities" $ divElt
    liftEff $ WS.setItem WS.localStorage savedStateKey dat
    case decode dat of
      Just (State { data = acts, years = y}) -> do
        chart y $ allActivities acts
      Nothing -> log "No data?!"

isOld :: Maybe Date -> Date -> Boolean
isOld Nothing _ = true
isOld (Just old) current =
  diff > Hours 1.0
  where
    t1 = toEpochMilliseconds old
    t2 = toEpochMilliseconds current
    diff = toHours $ t2 - t1

mainInteractive :: Aff (HalogenEffects (d3 :: Graphics.D3.Base.D3, feff :: CalendarChart.Util.FileEffect)) Unit
mainInteractive =  do
  cachedToken <- liftEff $ WS.getItem WS.localStorage stravaTokenKey
  savedState <- liftEff $ WS.getItem WS.localStorage savedStateKey

  Tuple node driver <- liftEff $ runUIWith (ui defaultState) \req elt driver -> updateChart elt
  liftEff $ appendToBody node

  --liftEff $ updateChart node

  let initialState = fromMaybe defaultState $ savedState >>= decode
  liftEff $ driver $ SavedState initialState
  current <- liftEff now
  case {s: initialState, t: cachedToken} of
    { s: State { lastPull: lp }, t: Just token } | isOld lp current -> do
      recentActs <- downloadedStrava token
      liftEff $ driver $ StravaDownloadData recentActs current
    _ -> return unit

  return unit

main = launchAff $ mainInteractive

module CalendarChart.Main where

import Prelude

import Data.Maybe
import Data.JSON

import CalendarChart.Chart
import CalendarChart.Activities
import CalendarChart.Strava
import CalendarChart.RA
import CalendarChart.Util

import Data.Array(mapMaybe,length,filter,concat,(..),findIndex,modifyAt,(:))
import Data.Date
import Data.Time
import Data.Tuple
import Data.Foldable(for_)

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Class(liftEff)
import Control.Monad.Aff(launchAff,Aff())
import Network.HTTP.Affjax
import Control.Monad.Eff.Console

import qualified Browser.WebStorage as WS

import Data.Either
import Data.Foreign(readString)
import Control.Bind
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Halogen
import Halogen.Signal
import Halogen.Component
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Types as ET
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import Data.Functor (($>))
import Control.Plus (empty)
import qualified Data.Int as I

import Network.RemoteCallback

fetchCont :: (Array Activity -> Eff _ (Unit)) -> Aff _ Unit
fetchCont chartf = do
  strava <- get "data/activities.json"
  let vals = fromMaybe [] $ decode $ strava.response
  ra <- get "data/log.txt"
  pp <- liftEff $ getRAfromText ra.response
  let acts = filter (\(Activity a) -> a.type == Run) $ vals ++ pp
  liftEff $ do
    chartf acts
    callPhantom false

mainWeek :: JSDate -> Eff _ Unit
mainWeek jsd =
  launchAff (fetchCont $ chartWeek dt)
  where
    dt :: Date
    dt = Data.Maybe.Unsafe.fromJust $ fromJSDate jsd

mainMonths = launchAff (fetchCont (chartMonths 1))

chart y = chartMonths y <<< filter (\(Activity a) -> a.type == Run)

stravaTokenKey = "stravaToken"
savedStateKey = "savedState"

downloadStrava :: forall e. Unit -> Aff (console :: CONSOLE, dom :: DOM | e) (Array Activity)
downloadStrava _ = do
  let stravaUrl = "https://www.strava.com/oauth/authorize?client_id=2746&response_type=code&redirect_uri=http://localhost:8123/token_exchange&scope=public&state=mystate&approval_prompt=force"
  cachedToken <- liftEff $ WS.getItem WS.localStorage stravaTokenKey

  case cachedToken of
    Nothing -> do
      liftEff $ log "Downloading Strava"
      let stravaUrl = "https://www.strava.com/oauth/authorize?client_id=2746&response_type=code&redirect_uri=http://localhost:8123/token_exchange&scope=public&state=mystate&approval_prompt=force"
      liftEff $ openWindow stravaUrl "login" "height=600,width=800"
      token <- externalCall "downloadedStrava"
      liftEff $ log $ "Got Strava token: " ++ token
      downloadedStrava token
    Just token -> do
      liftEff $ log "Got cached token"
      downloadedStrava token

downloadedStrava :: forall e. String -> Aff (console :: CONSOLE, dom :: DOM | e) (Array Activity)
downloadedStrava token = do
  liftEff $ log $ "Strava callback complete: " ++ token
  liftEff $ WS.setItem WS.localStorage stravaTokenKey token
  fetchStrava 1 token

fetchStrava :: forall e. Int -> String -> Aff (console :: CONSOLE, dom :: DOM | e) (Array Activity)
fetchStrava page token = do
  liftEff $ log "About to fetch strava data"
  let callback = "PS_FetchStrava_Callback"
  let url = "https://www.strava.com/api/v3/athlete/activities?per_page=200" ++ "&page=" ++ (show page) ++ "&access_token=" ++ token ++ "&callback=" ++ callback
  text <- jsonp callback url
  return $ getStravaFromText text

appendToBody :: forall eff. HTMLElement -> Eff (dom :: DOM | eff) Unit
appendToBody e = document globalWindow >>= (body >=> flip appendChild e)

dataActivities :: forall i. String -> A.Attr i
dataActivities = A.attr $ A.attributeName "data-activities"

data ActivityDetail = RunningAhead | StravaFile | StravaLink
data Activities = Activities ActivityDetail (Array Activity)

data State = State { data:: Array Activities, years:: Int, lastPull:: Maybe Date }

defaultState :: State
defaultState = State { data: [], years: 1, lastPull: Nothing }

instance activityDetailEq :: Eq ActivityDetail where
  eq RunningAhead RunningAhead = true
  eq StravaFile StravaFile = true
  eq StravaLink StravaLink = true
  eq _ _ = false

instance activitiesEq :: Eq Activities where
  eq (Activities d acts) (Activities d' acts') = d == d' && acts == acts'

instance activityDetailToJSON :: ToJSON ActivityDetail where
  toJSON RunningAhead = JString "ra"
  toJSON StravaFile = JString "stravafile"
  toJSON StravaLink = JString "strava"

instance activityDetailFromJSON :: FromJSON ActivityDetail where
  parseJSON (JString "ra") = pure RunningAhead
  parseJSON (JString "stravafile") = pure StravaFile
  parseJSON (JString "strava") = pure StravaLink

instance activitiesToJSON :: ToJSON Activities where
  toJSON (Activities detail acts) = object [ "detail" .= detail, "acts" .= acts ]

instance activitiesFromJSON :: FromJSON Activities where
  parseJSON (JObject o) = do
    detail <- o .: "detail"
    acts <- o .: "acts"
    return $ Activities detail acts

instance stateToJSON :: ToJSON State where
  toJSON (State { data = d, years = y, lastPull = lastPull }) =
    object [ "data" .= d, "years" .= y, "lastPull" .= lastPull ]

instance stateFromJSON :: FromJSON State where
  parseJSON (JObject o) = do
    d <- o .: "data"
    y <- o .: "years"
    lp <- o .: "lastPull"
    return $ State { data: d, years: y, lastPull : lp }

data Input = RaData (Array Activity) | StravaFileData (Array Activity) | Years Int | StravaDownloadData (Array Activity) Date | SavedState State

ui :: State -> Component (E.Event (HalogenEffects _)) Input Input
ui initialState = render <$> stateful initialState updateState
  where
  render :: State -> H.HTML (E.Event (HalogenEffects _) Input)
  render s@(State { data = activities, years = years}) = H.div_
    [ H.input [ A.type_ "file", A.id_ "rafileinput", A.onChange $ \e -> pure (do
        text <- E.async $ getFile e
        liftEff $ log "Got RA data"
        ra <- liftEff $ getRAfromText text
        return $ RaData ra
      ) ] []

    , H.input [ A.type_ "file", A.id_ "stravafileinput", A.onChange $ \e -> pure (do
        text <- E.async $ getFile e
        liftEff $ log "Got Strava data"
        let sa = getStravaFromText text
        return $ StravaFileData sa
      ) ] []

    , H.div [ A.classes [ A.className "header" ] ] [
          H.span [ A.classes [A.className "title"] ] [ H.text "Run Calendar" ]
        , H.span [ A.onClick $ clickFileInput "#rafileinput" ] [ H.text "RA" ]
        , H.span [ A.onClick $ clickFileInput "#stravafileinput", A.classes [A.className "strava"] ] [ H.img [ A.src "strava.svg"] [],  H.text "Strava/local" ]
        , H.span [ A.classes [A.className "strava"], A.onClick $ \_ -> pure (do
              sa <- E.async $ downloadStrava unit
              d <- liftEff $ now
              return $ StravaDownloadData sa d) ]
          [
            H.img [ A.src "strava.svg" ] []
          , H.text "Connect to Strava"
          ]
        , H.text "Years:"
        , H.span_ (yearLink years <$> 1..5 )
        , H.text $ "Data Sources: " ++  show (length activities)
      ]

    , H.div [ dataActivities $ encode s, A.classes [A.className "monthchart", A.className "hcl2"] ] []
    ]

  yearLink years y =
    if y == years then
      H.span [ A.classes [ A.className "year", A.className "selected" ] ] [ H.text $ show y ]
    else
      H.span [ A.onClick $ A.input_ $ Years y, A.classes [ A.className "year" ] ] [ H.text $ show y ]

  clickFileInput :: String -> ET.Event ET.MouseEvent -> E.EventHandler _
  clickFileInput selector _ = pure $ do
      (liftEff $ do
          doc <- document globalWindow
          fileInput <- querySelector selector doc
          case fileInput of
            Just i -> click i
            Nothing -> return unit)
      empty

  getFile e =
    case getElementFile e.target of
      Nothing -> return ""
      Just f -> readAsTextAff (fileReader unit) (fileAsBlob f)

  updateState :: State -> Input -> State
  updateState (State rec @ { data = s }) (RaData a) =
    State rec { data = mergeActs (Activities RunningAhead a) s }
  updateState (State rec @ { data = s }) (StravaFileData a) =
    State rec { data = mergeActs (Activities StravaFile a) s }
  updateState (State rec @ { data = s }) (StravaDownloadData a d) =
    State rec { data = mergeActs (Activities StravaLink a) s, lastPull = Just d }
  updateState (State s) (Years n) = State $ s { years = n }
  updateState (State s) (SavedState ss) = ss
  updateState (ss) _ = ss

mergeActs :: Activities -> Array Activities -> Array Activities
mergeActs (newActs@(Activities d acts)) aa =
  case findIndex (\(Activities d' _) -> d == d') aa of
    Just i -> fromMaybe [] (arr i)
    Nothing -> newActs : aa
  where
    arr :: Int -> Maybe (Array Activities)
    arr i = ((modifyAt i update aa) :: Maybe (Array Activities))
    update (Activities _ acts') = Activities d (acts++acts')

-- mergeActs :: Activities -> Array Activities -> Array Activities
-- mergeActs act [] = [act]
-- mergeActs (Activities d acts) (Activities d' acts' : rest) | d == d' = Activities d (acts++acts') : rest
-- mergeActs x (a : rest) = a : mergeActs x rest

allActivities :: Array Activities -> Array Activity
allActivities acts =
  concat $ toActivities <$> acts
  where
    toActivities (Activities _ acts) = acts

updateChart :: HTMLElement -> Eff (HalogenEffects (d3 :: Graphics.D3.Base.D3, feff :: CalendarChart.Util.FileEffect)) Unit
updateChart elt = do
  divElts <- querySelector ".monthchart" elt
  for_ divElts \divElt -> do
    dat <- getAttribute "data-activities" $ divElt
    liftEff $ WS.setItem WS.localStorage savedStateKey dat
    case decode dat of
      Just (State { data = acts, years = y}) -> do
        chart y $ allActivities acts
      Nothing -> log "No data?!"

isOld :: Maybe Date -> Date -> Boolean
isOld Nothing _ = true
isOld (Just old) current =
  diff > Hours 1
  where
    t1 = toEpochMilliseconds old
    t2 = toEpochMilliseconds current
    diff = toHours $ t2 - t1

mainInteractive :: Aff (HalogenEffects (d3 :: Graphics.D3.Base.D3, feff :: CalendarChart.Util.FileEffect)) Unit
mainInteractive =  do
  cachedToken <- liftEff $ WS.getItem WS.localStorage stravaTokenKey
  savedState <- liftEff $ WS.getItem WS.localStorage savedStateKey

  Tuple node driver <- liftEff $ runUIWith (ui defaultState) \req elt driver -> updateChart elt
  liftEff $ appendToBody node

  --liftEff $ updateChart node

  let initialState = fromMaybe defaultState $ savedState >>= decode
  liftEff $ driver $ SavedState initialState
  current <- liftEff now
  case {s: initialState, t: cachedToken} of
    { s: State { lastPull: lp }, t: Just token } | isOld lp current -> do
      recentActs <- downloadedStrava token
      liftEff $ driver $ StravaDownloadData recentActs current
    _ -> return unit

  return unit

main = launchAff $ mainInteractive


simplify null guard

simplify null guard

module Data.Foreign.Index
  ( Index

  , prop
  , index

  , (!)
  , hasProperty
  , hasOwnProperty
  , errorAt
  ) where

import Data.Either
import Data.Foreign
import Data.Function

infixl 9 !

class Index i where
  (!) :: Foreign -> i -> F Foreign
  hasProperty :: i -> Foreign -> Boolean
  hasOwnProperty :: i -> Foreign -> Boolean
  errorAt :: i -> ForeignError -> ForeignError

foreign import unsafeReadPropImpl
  """
  function unsafeReadPropImpl(f, s, key, value) {
    return value == null ? f : s(value[key]);
  }
  """ :: forall r k. Fn4 r (Foreign -> r) k Foreign (F Foreign)

unsafeReadProp :: forall k. k -> Foreign -> F Foreign
unsafeReadProp k value = runFn4 unsafeReadPropImpl (Left (TypeMismatch "object" (typeOf value))) pure k value

prop :: String -> Foreign -> F Foreign
prop = unsafeReadProp

index :: Number -> Foreign -> F Foreign
index = unsafeReadProp

foreign import unsafeHasOwnProperty
  """
  function unsafeHasOwnProperty(prop, value) {
    return Object.prototype.hasOwnProperty.call(value, prop);
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasOwnPropertyImpl :: forall k. k -> Foreign -> Boolean
hasOwnPropertyImpl _    value | isNull value = false
hasOwnPropertyImpl _    value | isUndefined value = false
hasOwnPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasOwnProperty prop value
hasOwnPropertyImpl _    value = false

foreign import unsafeHasProperty
  """
  function unsafeHasProperty(prop, value) {
    return prop in value;
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasPropertyImpl :: forall k. k -> Foreign -> Boolean
hasPropertyImpl _    value | isNull value = false
hasPropertyImpl _    value | isUndefined value = false
hasPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasProperty prop value
hasPropertyImpl _    value = false

instance indexString :: Index String where
  (!) = flip prop
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtProperty

instance indexNumber :: Index Number where
  (!) = flip index
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtIndex

module Data.Foreign.Index
  ( Index

  , prop
  , index

  , (!)
  , hasProperty
  , hasOwnProperty
  , errorAt
  ) where

import Data.Either
import Data.Foreign
import Data.Function

infixl 9 !

class Index i where
  (!) :: Foreign -> i -> F Foreign
  hasProperty :: i -> Foreign -> Boolean
  hasOwnProperty :: i -> Foreign -> Boolean
  errorAt :: i -> ForeignError -> ForeignError

foreign import unsafeReadPropImpl
  """
  function unsafeReadPropImpl(f, s, key, value) {
    if (value && typeof value === 'object') {
      return s(value[key]);
    } else {
      return f;
    }
  }
  """ :: forall r k. Fn4 r (Foreign -> r) k Foreign (F Foreign)

unsafeReadProp :: forall k. k -> Foreign -> F Foreign
unsafeReadProp k value = runFn4 unsafeReadPropImpl (Left (TypeMismatch "object" (typeOf value))) pure k value

prop :: String -> Foreign -> F Foreign
prop = unsafeReadProp

index :: Number -> Foreign -> F Foreign
index = unsafeReadProp

foreign import unsafeHasOwnProperty
  """
  function unsafeHasOwnProperty(prop, value) {
    return Object.prototype.hasOwnProperty.call(value, prop);
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasOwnPropertyImpl :: forall k. k -> Foreign -> Boolean
hasOwnPropertyImpl _    value | isNull value = false
hasOwnPropertyImpl _    value | isUndefined value = false
hasOwnPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasOwnProperty prop value
hasOwnPropertyImpl _    value = false

foreign import unsafeHasProperty
  """
  function unsafeHasProperty(prop, value) {
    return prop in value;
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasPropertyImpl :: forall k. k -> Foreign -> Boolean
hasPropertyImpl _    value | isNull value = false
hasPropertyImpl _    value | isUndefined value = false
hasPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasProperty prop value
hasPropertyImpl _    value = false

instance indexString :: Index String where
  (!) = flip prop
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtProperty

instance indexNumber :: Index Number where
  (!) = flip index
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtIndex


Fix broken example

Fix broken example

module Main where

import Prelude
import Effect (Effect)
import Effect.Aff (delay, launchAff_)
import Data.Time.Duration (Milliseconds(..))
import Test.Spec (pending, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)

main :: Effect Unit
main = launchAff_ $ run [consoleReporter] do
  describe "purescript-spec" do
    describe "Attributes" do
      it "awesome" do
        let isAwesome = true
        isAwesome `shouldEqual` true
      pending "feature complete"
    describe "Features" do
      it "runs in NodeJS" $ pure unit
      it "runs in the browser" $ pure unit
      it "supports streaming reporters" $ pure unit
      it "supports async specs" do
        res <- delay (Milliseconds 100.0) *> pure "Alligator"
        res `shouldEqual` "Alligator"
      it "is PureScript 0.12.x compatible" $ pure unit

module Main where

import Prelude
import Effect (Effect)
import Effect.Aff (delay)
import Data.Time.Duration (Milliseconds(..))
import Test.Spec (pending, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)

main :: Effect Unit
main = run [consoleReporter] do
  describe "purescript-spec" do
    describe "Attributes" do
      it "awesome" do
        let isAwesome = true
        isAwesome `shouldEqual` true
      pending "feature complete"
    describe "Features" do
      it "runs in NodeJS" $ pure unit
      it "runs in the browser" $ pure unit
      it "supports streaming reporters" $ pure unit
      it "supports async specs" do
        res <- delay (Milliseconds 100.0) *> pure "Alligator"
        res `shouldEqual` "Alligator"
      it "is PureScript 0.10.x compatible" $ pure unit


Temporary hack to get the test reliably working

module Test where

import Prelude
import Data.Maybe
import Data.Either
import Control.Apply ((*>))
import Control.Bind ((=<<))
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Console (log)
import Node.Encoding
import qualified Node.Buffer as Buffer
import qualified Node.Path as Path
import Unsafe.Coerce

import Node.FS
import Node.FS.Stats
import qualified Node.FS.Async as A
import qualified Node.FS.Sync as S

-- Cheat to allow `main` to type check. See also issue #5 in
-- purescript-exceptions.
catchException' ::
  forall a eff.
    (Error -> Eff (err :: EXCEPTION | eff) a)
    -> Eff (err :: EXCEPTION | eff) a
    -> Eff (err :: EXCEPTION | eff) a
catchException' = unsafeCoerce catchException

main = do
  let fp = Path.concat

  A.exists (fp ["examples", "Test.purs"]) $ \e ->
    log $ "Test.purs exists? " ++ show e

  file <- S.readTextFile UTF8 (fp ["examples", "Test.purs"])
  log "\n\nreadTextFile sync result:"
  log $ file

  catchException' (\err -> do
    log $ "Caught readTextFile error:\n" ++ show err
    return "") $ S.readTextFile UTF8 (fp ["examples", "does not exist"])

  -- If an error is thrown, it's probably EEXIST, so ignore it. Should
  -- really check this instead.
  catchException' (const (return unit)) (S.mkdir "tmp")

  S.writeTextFile ASCII (fp ["tmp", "Test.js"]) "console.log('hello world')"
  S.rename (fp ["tmp", "Test.js"]) (fp ["tmp", "Test1.js"])

  S.truncate (fp ["tmp", "Test1.js"]) 1000

  stats <- S.stat (fp ["tmp", "Test1.js"])
  log "\n\nS.stat:"
  log "isFile:"
  log $ show $ isFile stats
  log "isDirectory:"
  log $ show $ isDirectory stats
  log "isBlockDevice:"
  log $ show $ isBlockDevice stats
  log "isCharacterDevice:"
  log $ show $ isCharacterDevice stats
  log "isFIFO:"
  log $ show $ isFIFO stats
  log "isSocket:"
  log $ show $ isSocket stats
  log "isSymbolicLink:"
  log $ show $ isSymbolicLink stats
  log "modifiedTime:"
  log $ show $ modifiedTime stats
  log "accessedTime:"
  log $ show $ accessedTime stats
  log "statusChangedTime:"
  log $ show $ statusChangedTime stats

  A.rename (fp ["tmp", "Test1.js"]) (fp ["tmp", "Test.js"]) $ \x -> do
    log "\n\nrename result:"
    either (log <<< show) (log <<< show) x

    A.truncate (fp ["tmp", "Test.js"]) 10 $ \x -> do
      log "\n\ntruncate result:"
      either (log <<< show) (log <<< show) x

  A.readFile (fp ["examples", "Test.purs"]) $ \x -> do
    log "\n\nreadFile result:"
    either (log <<< show) (log <<< show) x

  A.readTextFile UTF8 (fp ["examples", "Test.purs"]) $ \x -> do
    log "\n\nreadTextFile result:"
    either (log <<< show) log x

  A.stat (fp ["examples", "Test.purs"]) $ \x -> do
    log "\n\nstat:"
    case x of
      Left err -> log $ "Error:" ++ show err
      Right x' -> do
        log "isFile:"
        log $ show $ isFile x'
        log "isDirectory:"
        log $ show $ isDirectory x'
        log "isBlockDevice:"
        log $ show $ isBlockDevice x'
        log "isCharacterDevice:"
        log $ show $ isCharacterDevice x'
        log "isFIFO:"
        log $ show $ isFIFO x'
        log "isSocket:"
        log $ show $ isSocket x'
        log "isSymbolicLink:"
        log $ show $ isSymbolicLink x'
        log "modifiedTime:"
        log $ show $ modifiedTime x'
        log "accessedTime:"
        log $ show $ accessedTime x'
        log "statusChangedTime:"
        log $ show $ statusChangedTime x'

  let fdFile = fp ["tmp", "FD.json"]
  fd0 <- S.fdOpen fdFile W (Just 420)
  buf0 <- Buffer.fromString "[ 42 ]" UTF8
  bytes0 <- S.fdAppend fd0 buf0
  S.fdFlush fd0
  S.fdClose fd0
  fd1 <- S.fdOpen fdFile R Nothing
  buf1 <- Buffer.create =<< Buffer.size buf0
  bytes1 <- S.fdNext fd1 buf1
  S.fdClose fd1

module Test where

import Prelude
import Data.Maybe
import Data.Either
import Control.Apply ((*>))
import Control.Bind ((=<<))
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Console (log)
import Node.Encoding
import qualified Node.Buffer as Buffer
import qualified Node.Path as Path
import Unsafe.Coerce

import Node.FS
import Node.FS.Stats
import qualified Node.FS.Async as A
import qualified Node.FS.Sync as S

-- Cheat to allow `main` to type check. See also issue #5 in
-- purescript-exceptions.
catchException' ::
  forall a eff.
    (Error -> Eff (err :: EXCEPTION | eff) a)
    -> Eff (err :: EXCEPTION | eff) a
    -> Eff (err :: EXCEPTION | eff) a
catchException' = unsafeCoerce catchException

main = do
  let fp = Path.concat

  A.exists (fp ["examples", "Test.purs"]) $ \e ->
    log $ "Test.purs exists? " ++ show e

  file <- S.readTextFile UTF8 (fp ["examples", "Test.purs"])
  log "\n\nreadTextFile sync result:"
  log $ file

  catchException' (\err -> do
    log $ "Caught readTextFile error:\n" ++ show err
    return "") $ S.readTextFile UTF8 (fp ["examples", "does not exist"])

  S.rename (fp ["tmp", "Test.js"]) (fp ["tmp", "Test1.js"])

  S.truncate (fp ["tmp", "Test1.js"]) 1000

  stats <- S.stat (fp ["tmp", "Test1.js"])
  log "\n\nS.stat:"
  log "isFile:"
  log $ show $ isFile stats
  log "isDirectory:"
  log $ show $ isDirectory stats
  log "isBlockDevice:"
  log $ show $ isBlockDevice stats
  log "isCharacterDevice:"
  log $ show $ isCharacterDevice stats
  log "isFIFO:"
  log $ show $ isFIFO stats
  log "isSocket:"
  log $ show $ isSocket stats
  log "isSymbolicLink:"
  log $ show $ isSymbolicLink stats
  log "modifiedTime:"
  log $ show $ modifiedTime stats
  log "accessedTime:"
  log $ show $ accessedTime stats
  log "statusChangedTime:"
  log $ show $ statusChangedTime stats

  A.rename (fp ["tmp", "Test1.js"]) (fp ["tmp", "Test.js"]) $ \x -> do
    log "\n\nrename result:"
    either (log <<< show) (log <<< show) x

    A.truncate (fp ["tmp", "Test.js"]) 10 $ \x -> do
      log "\n\ntruncate result:"
      either (log <<< show) (log <<< show) x

  A.readFile (fp ["examples", "Test.purs"]) $ \x -> do
    log "\n\nreadFile result:"
    either (log <<< show) (log <<< show) x

  A.readTextFile UTF8 (fp ["examples", "Test.purs"]) $ \x -> do
    log "\n\nreadTextFile result:"
    either (log <<< show) log x

  A.stat (fp ["examples", "Test.purs"]) $ \x -> do
    log "\n\nstat:"
    case x of
      Left err -> log $ "Error:" ++ show err
      Right x' -> do
        log "isFile:"
        log $ show $ isFile x'
        log "isDirectory:"
        log $ show $ isDirectory x'
        log "isBlockDevice:"
        log $ show $ isBlockDevice x'
        log "isCharacterDevice:"
        log $ show $ isCharacterDevice x'
        log "isFIFO:"
        log $ show $ isFIFO x'
        log "isSocket:"
        log $ show $ isSocket x'
        log "isSymbolicLink:"
        log $ show $ isSymbolicLink x'
        log "modifiedTime:"
        log $ show $ modifiedTime x'
        log "accessedTime:"
        log $ show $ accessedTime x'
        log "statusChangedTime:"
        log $ show $ statusChangedTime x'

  let fdFile = fp ["tmp", "FD.json"]
  fd0 <- S.fdOpen fdFile W (Just 420)
  buf0 <- Buffer.fromString "[ 42 ]" UTF8
  bytes0 <- S.fdAppend fd0 buf0
  S.fdFlush fd0
  S.fdClose fd0
  fd1 <- S.fdOpen fdFile R Nothing
  buf1 <- Buffer.create =<< Buffer.size buf0
  bytes1 <- S.fdNext fd1 buf1
  S.fdClose fd1


Fix test warnings

Fix test warnings

module Test.Main where

import Prelude (Unit)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)

import Data.Argonaut.Combinators ((~>), (:=))
import Data.Argonaut.Core (jsonEmptyObject)

import Test.Spec (it, describe)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (Process, run)

import Electron (ELECTRON)
import Electron.BrowserWindow (BrowserWindowOption(WebPreferences, Height, Width), WebPreference(OverlayScrollbars))
import Electron.Options (encodeOptions)

main :: forall eff. Eff (console :: CONSOLE, process :: Process, electron :: ELECTRON | eff) Unit
main = run [consoleReporter] do
  describe "encodeOptions :: BrowserWindowOptions -> Json" do
    it "can encode all options" do
      let options = [Width 640, Height 480, WebPreferences [OverlayScrollbars true]]
      encodeOptions options `shouldEqual` (  "width"  := 640
                                          ~> "height" := 480
                                          ~> "webPreferences" := ( "overlayScrollbars" := true
                                                                 ~> jsonEmptyObject )
                                          ~> jsonEmptyObject )

module Test.Main where

import Prelude

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Data.Argonaut.Core
import Data.Argonaut.Combinators

import Test.Spec
import Test.Spec.Assertions
import Test.Spec.Reporter.Console
import Test.Spec.Runner

import Electron
import Electron.BrowserWindow
import Electron.Options

main :: forall eff. Eff (console :: CONSOLE, process :: Process, electron :: ELECTRON | eff) Unit
main = run [consoleReporter] do
  describe "encodeOptions :: BrowserWindowOptions -> Json" do
    it "can encode all options" do
      let options = [Width 640, Height 480, WebPreferences [OverlayScrollbars true]]
      encodeOptions options `shouldEqual` (  "width"  := 640
                                          ~> "height" := 480
                                          ~> "webPreferences" := ( "overlayScrollbars" := true
                                                                 ~> jsonEmptyObject )
                                          ~> jsonEmptyObject )


Remove RoutableMethod

Remove RoutableMethod

module Hyper.Routing.DataRouter
       ( GET
       , POST
       , Path
       , Route(..)
       , class Addressable
       , toPath
       , class Routable
       , fromRoute
       , router
       , linkTo
       , formFor
       ) where

import Prelude
import Hyper.Method as Method
import Data.Array (filter)
import Data.Leibniz (type (~))
import Data.Maybe (Maybe(Nothing, Just))
import Data.String (joinWith, Pattern(Pattern), split)
import Data.Tuple (Tuple(Tuple))
import Hyper.Core (TryMiddleware(TryMiddleware), Conn, Middleware)
import Hyper.HTML (element, a, form, HTML)
import Hyper.Method (Method)

data GET
data POST

type Path = Array String

pathToHtml :: Path -> String
pathToHtml = (<>) "/" <<< joinWith "/"

pathFromString :: String -> Path
pathFromString = filter ((/=) "") <<< split (Pattern "/")

data Route m = Route Path

class Addressable r where
  toPath :: forall m. r m -> Path

class Routable r m where
  fromRoute :: Route m -> Maybe (r m)

type MethodRequestHandler r method m req res c req' res' c' =
  r method -> Middleware
              m
              (Conn { method :: Method, url :: String | req } res c)
              (Conn req' res' c')

routeWith :: forall c r method m c'.
  ( Routable r method , Functor m , Applicative m ) =>
  c -> Route method -> (r method -> c -> m c') -> m (Maybe c')
routeWith conn route handler =
  case fromRoute route of
    Just requestable ->
      Just <$> handler requestable conn
    Nothing -> pure Nothing

router
  :: forall m r req res c req' res' c'.
     (Applicative m, Routable r GET, Routable r POST) =>
  { get :: MethodRequestHandler r GET m req res c req' res' c'
  , post :: MethodRequestHandler r POST m req res c req' res' c'
  }
  -> TryMiddleware m
                   (Conn { method :: Method, url :: String | req } res c)
                   (Conn req' res' c')
router handlers = TryMiddleware router'
  where
    router' conn =
      let path = pathFromString conn.request.url
      in case conn.request.method of
        Method.GET -> routeWith conn (Route path) handlers.get
        Method.POST -> routeWith conn (Route path) handlers.post

type WithMethod m r = (m ~ m) -> r m

linkTo
  :: forall r. Addressable r =>
     WithMethod GET r
  -> Array HTML
  -> HTML
linkTo r children =
  case toPath (r id) of
    path ->
      a [Tuple "href" (pathToHtml path)] children

formFor
  :: forall r a. (Addressable r, Show a) =>
     (a -> WithMethod POST r)
  -> a
  -> HTML
formFor r value =
  case toPath (r value id) of
    path ->
      form
      [ Tuple "method" "POST"
      , Tuple "action" (pathToHtml path)
      ]
      -- Dummy implementation for now...
      [ element
        "input"
        [ Tuple "name" "value"
        , Tuple "value" (show value)
        ]
        []
      ]

module Hyper.Routing.DataRouter
       ( GET
       , POST
       , Path
       , Route(..)
       , class Addressable
       , toPath
       , class Routable
       , fromRoute
       , class RoutableMethod
       , getMethod
       , router
       , linkTo
       , formFor
       ) where

import Prelude
import Hyper.Method as Method
import Data.Array (filter)
import Data.Leibniz (type (~))
import Data.Maybe (Maybe(Nothing, Just))
import Data.String (joinWith, Pattern(Pattern), split)
import Data.Tuple (Tuple(Tuple))
import Hyper.Core (TryMiddleware(TryMiddleware), Conn, Middleware)
import Hyper.HTML (element, a, form, HTML)
import Hyper.Method (Method)

data GET
data POST

type Path = Array String

pathToHtml :: Path -> String
pathToHtml = (<>) "/" <<< joinWith "/"

pathFromString :: String -> Path
pathFromString = filter ((/=) "") <<< split (Pattern "/")

data Route m = Route Path

class Addressable r where
  toPath :: forall m. r m -> Path

class Routable r m where
  fromRoute :: Route m -> Maybe (r m)

class RoutableMethod m where
  getMethod :: Method

instance routableMethodGET :: RoutableMethod GET where
  getMethod = Method.GET

instance routableMethodPOST :: RoutableMethod POST where
  getMethod = Method.POST

type MethodRequestHandler r method m req res c req' res' c' =
  r method -> Middleware
              m
              (Conn { method :: Method, url :: String | req } res c)
              (Conn req' res' c')

routeWith :: forall c r method m c'.
  ( Routable r method , Functor m , Applicative m ) =>
  c -> Route method -> (r method -> c -> m c') -> m (Maybe c')
routeWith conn route handler =
  case fromRoute route of
    Just requestable ->
      Just <$> handler requestable conn
    Nothing -> pure Nothing

router
  :: forall m r req res c req' res' c'.
     (Applicative m, Routable r GET, Routable r POST) =>
  { get :: MethodRequestHandler r GET m req res c req' res' c'
  , post :: MethodRequestHandler r POST m req res c req' res' c'
  }
  -> TryMiddleware m
                   (Conn { method :: Method, url :: String | req } res c)
                   (Conn req' res' c')
router handlers = TryMiddleware router'
  where
    router' conn =
      let path = pathFromString conn.request.url
      in case conn.request.method of
        Method.GET -> routeWith conn (Route path) handlers.get
        Method.POST -> routeWith conn (Route path) handlers.post

type WithMethod m r = (m ~ m) -> r m

linkTo
  :: forall r. Addressable r =>
     WithMethod GET r
  -> Array HTML
  -> HTML
linkTo r children =
  case toPath (r id) of
    path ->
      a [Tuple "href" (pathToHtml path)] children

formFor
  :: forall r a. (Addressable r, Show a) =>
     (a -> WithMethod POST r)
  -> a
  -> HTML
formFor r value =
  case toPath (r value id) of
    path ->
      form
      [ Tuple "method" "POST"
      , Tuple "action" (pathToHtml path)
      ]
      -- Dummy implementation for now...
      [ element
        "input"
        [ Tuple "name" "value"
        , Tuple "value" (show value)
        ]
        []
      ]