added haskell scratch directory

haskell-experiments/.direnv/bin/nix-direnv-reload

@@ -0,0 +1,19 @@
+#!/usr/bin/env bash
+set -e
+if [[ ! -d "/home/felix/projects/pyrites/haskell-experiments" ]]; then
+  echo "Cannot find source directory; Did you move it?"
+  echo "(Looking for "/home/felix/projects/pyrites/haskell-experiments")"
+  echo 'Cannot force reload with this script - use "direnv reload" manually and then try again'
+  exit 1
+fi
+
+# rebuild the cache forcefully
+_nix_direnv_force_reload=1 direnv exec "/home/felix/projects/pyrites/haskell-experiments" true
+
+# Update the mtime for .envrc.
+# This will cause direnv to reload again - but without re-building.
+touch "/home/felix/projects/pyrites/haskell-experiments/.envrc"
+
+# Also update the timestamp of whatever profile_rc we have.
+# This makes sure that we know we are up to date.
+touch -r "/home/felix/projects/pyrites/haskell-experiments/.envrc" "/home/felix/projects/pyrites/haskell-experiments/.direnv"/*.rc

haskell-experiments/.direnv/nix-profile-.3357.d351d0653aeb

@@ -0,0 +1 @@
+/nix/store/yh4sq3dlkly5x6szw95xn5nlw4rn9xz3-ghc-shell-for-haskell-exps-0.1.0.0-0-env

haskell-experiments/.envrc

@@ -0,0 +1 @@
+use nix

haskell-experiments/.idea/.gitignore

@@ -0,0 +1,5 @@
+# Default ignored files
+/shelf/
+/workspace.xml
+# Environment-dependent path to Maven home directory
+/mavenHomeManager.xml

haskell-experiments/.idea/codeStyles/Project.xml

@@ -0,0 +1,7 @@
+<component name="ProjectCodeStyleConfiguration">
+  <code_scheme name="Project" version="173">
+    <ScalaCodeStyleSettings>
+      <option name="MULTILINE_STRING_CLOSING_QUOTES_ON_NEW_LINE" value="true" />
+    </ScalaCodeStyleSettings>
+  </code_scheme>
+</component>

haskell-experiments/.idea/codeStyles/codeStyleConfig.xml

@@ -0,0 +1,5 @@
+<component name="ProjectCodeStyleConfiguration">
+  <state>
+    <option name="PREFERRED_PROJECT_CODE_STYLE" value="Default" />
+  </state>
+</component>

haskell-experiments/.idea/material_theme_project_new.xml

@@ -0,0 +1,10 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<project version="4">
+  <component name="MaterialThemeProjectNewConfig">
+    <option name="metadata">
+      <MTProjectMetadataState>
+        <option name="userId" value="-70c0f615:19bbbe81457:-7f6e" />
+      </MTProjectMetadataState>
+    </option>
+  </component>
+</project>

haskell-experiments/.idea/misc.xml

@@ -0,0 +1,6 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<project version="4">
+  <component name="ProjectRootManager">
+    <output url="file://$PROJECT_DIR$/out" />
+  </component>
+</project>

haskell-experiments/.idea/modules.xml

@@ -0,0 +1,8 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<project version="4">
+  <component name="ProjectModuleManager">
+    <modules>
+      <module fileurl="file://$PROJECT_DIR$/haskell-experiments.iml" filepath="$PROJECT_DIR$/haskell-experiments.iml" />
+    </modules>
+  </component>
+</project>

haskell-experiments/.idea/vcs.xml

@@ -0,0 +1,6 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<project version="4">
+  <component name="VcsDirectoryMappings">
+    <mapping directory="$PROJECT_DIR$/.." vcs="Git" />
+  </component>
+</project>

haskell-experiments/haskell-experiments.cabal

@@ -0,0 +1,95 @@
+cabal-version:      3.0
+-- The cabal-version field refers to the version of the .cabal specification,
+-- and can be different from the cabal-install (the tool) version and the
+-- Cabal (the library) version you are using. As such, the Cabal (the library)
+-- version used must be equal or greater than the version stated in this field.
+-- Starting from the specification version 2.2, the cabal-version field must be
+-- the first thing in the cabal file.
+
+-- Initial package description 'haskell-exps' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+--
+-- The name of the package.
+name:               haskell-experiments
+
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
+-- https://pvp.haskell.org
+-- PVP summary:     +-+------- breaking API changes
+--                  | | +----- non-breaking API additions
+--                  | | | +--- code changes with no API change
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+synopsis:           Sandbox
+
+-- A longer description of the package.
+-- description:
+
+-- The license under which the package is released.
+license:            BSD-3-Clause
+
+-- The file containing the license text.
+license-file:       LICENSE
+
+-- The package author(s).
+author:             fdilke
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+maintainer:         fdilke@gmail.com
+
+-- A copyright notice.
+-- copyright:
+category:           Development
+build-type:         Simple
+
+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
+extra-doc-files:    CHANGELOG.md
+
+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+test-suite haskell-exps-test
+    -- Import common warning flags.
+    import:           warnings
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- The interface type and version of the test suite.
+    type:             exitcode-stdio-1.0
+
+    -- Directories containing source files.
+    hs-source-dirs:   test
+
+    -- The entrypoint to the test suite.
+    main-is:          Main.hs
+
+    -- Test dependencies.
+    build-depends:    base, hspec, langfeatures
+    other-modules:    Test.OlogsSpec
+
+
+library langfeatures
+  build-depends:   base, containers
+  hs-source-dirs:  src
+  exposed-modules: Ologs
+  ghc-options:     -Wall
+
+executable haskell-experiments
+  build-depends:    base, containers
+  main-is:          Main.hs
+  hs-source-dirs:   src
+  default-language: Haskell2010
+

haskell-experiments/haskell-experiments.iml

@@ -0,0 +1,9 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<module type="WEB_MODULE" version="4">
+  <component name="NewModuleRootManager" inherit-compiler-output="true">
+    <exclude-output />
+    <content url="file://$MODULE_DIR$" />
+    <orderEntry type="inheritedJdk" />
+    <orderEntry type="sourceFolder" forTests="false" />
+  </component>
+</module>

haskell-experiments/haskell-experiments.nix

@@ -0,0 +1,15 @@
+{ mkDerivation, base, hspec, lib }:
+mkDerivation {
+  pname = "haskell-exps";
+  version = "0.1.0.0";
+  src = ./.;
+  isLibrary = false;
+  isExecutable = true;
+  libraryHaskellDepends = [ base ];
+  executableHaskellDepends = [ base ];
+  testHaskellDepends = [ base hspec ];
+  doHaddock = false;
+  description = "Sandbox";
+  license = lib.licenses.bsd3;
+  mainProgram = "haskell-exps";
+}

haskell-experiments/haskell-parsing.iml

@@ -0,0 +1,9 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<module type="WEB_MODULE" version="4">
+  <component name="NewModuleRootManager" inherit-compiler-output="true">
+    <exclude-output />
+    <content url="file://$MODULE_DIR$" />
+    <orderEntry type="inheritedJdk" />
+    <orderEntry type="sourceFolder" forTests="false" />
+  </component>
+</module>

haskell-experiments/shell.nix

@@ -0,0 +1,12 @@
+{pkgs ? import <nixpkgs> {}}:
+pkgs.haskellPackages.shellFor {
+  packages = hpkgs: [
+    (hpkgs.callPackage ./haskell-experiments.nix {})
+  ];
+  nativeBuildInputs = with pkgs; [
+    haskell-language-server
+    cabal-install
+  ];
+  withHoogle = true;
+  shellHook = "unset TEMP TMP TEMPDIR TMPDIR";
+}

haskell-experiments/src/Main.hs

@@ -0,0 +1,5 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Hello Haskell!"
+

haskell-experiments/src/Ologs.hs

@@ -0,0 +1,237 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# HLINT ignore "Unused LANGUAGE pragma" #-}
+{-# HLINT ignore "Use concatMap" #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# HLINT ignore "Move catMaybes" #-}
+{-# HLINT ignore "Use mapMaybe" #-}
+{-# HLINT ignore "Use list comprehension" #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+module Ologs
+  ( Arc,
+    Identity,
+    Olog,
+    makeOlog,
+    MakeOlogError (..),
+  )
+where
+
+import Control.Monad
+import Data.Foldable (for_)
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import qualified Data.List.NonEmpty as NE
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Traversable
+import Debug.Trace
+
+data Arc dot = Arc
+  { name :: String,
+    source :: dot,
+    target :: dot
+  }
+  deriving (Show, Eq)
+
+data Identity = Identity
+  { lhs :: [String],
+    rhs :: [String]
+  }
+  deriving (Show, Eq)
+
+data Olog dot = Olog
+  { dots :: [dot],
+    arcs :: [Arc dot],
+    identities :: [Identity]
+  }
+  deriving (Show, Eq)
+
+makeOlogOld ::
+  forall dot.
+  (Eq dot, Show dot) =>
+  [dot] ->
+  [(String, dot, dot)] ->
+  [([String], [String])] ->
+  Either (MakeOlogError dot) (Olog dot)
+makeOlogOld dots preArcs preIdentities =
+  case errors of
+    [] ->
+      Right $
+        Olog
+          dots
+          (map (\(name, src, tgt) -> Arc {name = name, source = src, target = tgt}) preArcs)
+          ( (\(path1, path2) -> Identity {lhs = path1, rhs = path2}) <$> preIdentities
+          )
+    err : _ -> Left err
+  where
+    errorUnless b e = if b then Nothing else Just e
+    errors :: [MakeOlogError dot] = arcErrors <> identityErrors
+    arcErrors =
+      concat . concat $
+        map
+          ( fmap maybeToList . \(dotMapper, errorPrefix) ->
+              map (\arc@(name, _, _) -> (\dot -> errorUnless (dot `elem` dots) $ errorPrefix name dot) $ dotMapper arc) preArcs
+          )
+          [ (\(_, src, _) -> src, UnknownSource),
+            (\(_, _, tgt) -> tgt, UnknownTarget)
+          ]
+    knownArcNames = map (\(name, _, _) -> name) preArcs
+    identityErrors :: [MakeOlogError dot] =
+      identityKnownArcErrors <> identityLhsJoinErrors <> identityRhsJoinErrors <> identityMismatchErrors
+    identityKnownArcErrors =
+      concat $
+        map
+          ( \(lhs, rhs) ->
+              -- TODO: don't need to check triviality here
+              (if null lhs && null rhs then [ForbiddenTrivialIdentity] else [])
+                <> catMaybes
+                  ( map
+                      (\arcName -> errorUnless (arcName `elem` knownArcNames) $ UnknownArc arcName)
+                      $ lhs <> rhs
+                  )
+          )
+          preIdentities
+    namesToArcs :: Map String (dot, dot) = Map.fromList $ (\(s, src, tgt) -> (s, (src, tgt))) <$> preArcs
+    identityLhsJoinErrors = identityXhsJoinErrors NonJoiningExpressionLhs fst
+    identityRhsJoinErrors = identityXhsJoinErrors NonJoiningExpressionRhs snd
+    identityXhsJoinErrors ::
+      ([String] -> MakeOlogError dot) ->
+      (([String], [String]) -> [String]) ->
+      [MakeOlogError dot]
+    identityXhsJoinErrors errorFactory picker = catMaybes $ map (checkTerm errorFactory . picker) preIdentities
+    checkTerm :: ([String] -> MakeOlogError dot) -> [String] -> Maybe (MakeOlogError dot)
+    checkTerm errorFactory arcNames = errorUnless (targets == sources) $ errorFactory arcNames
+      where
+        arcs :: [(dot, dot)] = catMaybes $ flip Map.lookup namesToArcs <$> arcNames
+        targets :: [dot] = tail $ snd <$> arcs
+        sources :: [dot] = init $ fst <$> arcs
+    identityMismatchErrors = catMaybes $ checkMismatch <$> preIdentities
+    checkMismatch :: ([String], [String]) -> Maybe (MakeOlogError dot)
+    checkMismatch (lhs, rhs) = do
+      nonEmptyLhsAndSig <- case nonEmpty lhs of
+        Nothing ->
+          -- lhs empty
+          Just Nothing
+        Just nonEmptyLhs -> do
+          -- lhs non-empty
+          sig <- signature nonEmptyLhs
+          Just $ Just sig
+      nonEmptyRhsAndSig <- case nonEmpty rhs of
+        Nothing ->
+          -- rhs empty
+          Just Nothing
+        Just nonEmptyRhs -> do
+          -- rhs non-empty
+          sig <- signature nonEmptyRhs
+          Just $ Just sig
+      case (nonEmptyLhsAndSig, nonEmptyRhsAndSig) of
+        (Nothing, Nothing) ->
+          -- both empty
+          Just ForbiddenTrivialIdentity
+        (Just (src, tgt), Nothing) ->
+          -- right empty
+          errorUnless (src == tgt) $ NotALoop lhs
+        (Nothing, Just (src, tgt)) ->
+          -- left empty
+          errorUnless (src == tgt) $ NotALoop rhs
+        (Just lSig, Just rSig) ->
+          -- both non-empty
+          errorUnless (lSig == rSig) $ IdentityMismatch lhs rhs lSig rSig
+      where
+        signature :: NonEmpty String -> Maybe (dot, dot)
+        signature terms =
+          case Map.lookup (NE.last terms) namesToArcs of
+            Nothing -> Nothing
+            Just (src, _) ->
+              case Map.lookup (NE.head terms) namesToArcs of
+                Nothing -> Nothing
+                Just (_, tgt) -> Just (src, tgt)
+
+-- type f $ x = f x
+-- type ($) f x = f x
+
+data MakeOlogError dot
+  = UnknownSource String dot
+  | UnknownTarget String dot
+  | ForbiddenTrivialIdentity
+  | UnknownArc String
+  | NonJoiningExpressionLhs [String]
+  | NonJoiningExpressionRhs [String]
+  | IdentityMismatch [String] [String] (dot, dot) (dot, dot)
+  | NotALoop [String]
+  deriving (Show, Eq)
+
+makeOlog ::
+  forall dot.
+  (Eq dot) =>
+  [dot] ->
+  [(String, dot, dot)] ->
+  [([String], [String])] ->
+  Either (MakeOlogError dot) (Olog dot)
+makeOlog dots preArcs preIdentities = do
+  arcs <- for preArcs \(name, source, target) -> do
+    -- TODO reuse `namesToArcs`?
+    unless (source `elem` dots) $ Left $ UnknownSource name source
+    unless (target `elem` dots) $ Left $ UnknownTarget name target
+    pure Arc{name, source, target}
+  identities <- for preIdentities \(lhs, rhs) -> do
+    lhs' :: [(String, (dot, dot))] <- for lhs \arcName -> case Map.lookup arcName namesToArcs of
+      Nothing -> Left $ UnknownArc arcName
+      Just srcAndTgt -> pure (arcName, srcAndTgt)
+    rhs' :: [(String, (dot, dot))] <- for rhs \arcName -> case Map.lookup arcName namesToArcs of
+      Nothing -> Left $ UnknownArc arcName
+      Just srcAndTgt -> pure (arcName, srcAndTgt)
+    case (nonEmpty lhs', nonEmpty rhs') of
+      (Nothing, Nothing) ->
+        Left ForbiddenTrivialIdentity
+      (Just l, Nothing) -> do
+        checkTerm NonJoiningExpressionLhs l
+        let (_, (_, tgt)) = NE.head l
+        let (_, (src, _)) = NE.last l
+        errorWhen (src /= tgt) $ NotALoop lhs
+      (Nothing, Just r) -> do
+        checkTerm NonJoiningExpressionRhs r
+        let (_, (_, tgt)) = NE.head r
+        let (_, (src, _)) = NE.last r
+        errorWhen (src /= tgt) $ NotALoop rhs
+      (Just l, Just r) -> do
+        checkTerm NonJoiningExpressionLhs l
+        checkTerm NonJoiningExpressionRhs r
+        let combinedSrcTgt xhs = (fst $ snd $ NE.last xhs, snd $ snd $ NE.head xhs)
+            l' = combinedSrcTgt l
+            r' = combinedSrcTgt r
+        errorWhen (l' /=  r') $ IdentityMismatch lhs rhs l' r'
+    pure Identity {lhs, rhs}
+  pure Olog {dots, arcs, identities}
+  where
+    checkTerm errorFactory arcs = do
+      let
+        targets = NE.tail $ snd . snd <$> (arcs :: (NonEmpty (String, (dot, dot))))
+        sources = NE.init $ fst . snd <$> arcs
+      errorWhen (sources /= targets) $ errorFactory $ map fst $ NE.toList arcs 
+    errorWhen b e = if b then Left e else Right ()
+    namesToArcs = Map.fromList $ (\(name, src, tgt) -> (name, (src, tgt))) <$> preArcs
+
+-- checkArc :: (PreArc dot -> dot, String) -> PreArc dot -> Maybe String
+-- checkArc (mapper, errorPrefix) preArc =
+--   if mapper preArc `elem` dots then Nothing else Just $ errorPrefix <> show dot
+-- checkers :: [(PreArc dot -> dot, String)] =
+--   [ (\(_, src, _) -> src, "bad source: "),
+--     (\(_, _, tgt) -> tgt, "bad target: ")
+--   ]
+-- applyChecker :: (PreArc dot -> dot, String) -> Maybe String
+-- applyChecker (mapper, prefix) =
+--   map mapper arcs
+-- rawStrings :: [Maybe String] = map applyChecker [
+--   (\(_, src, _) -> src, "bad source: "),
+--     (\(_, _, tgt) -> tgt, "bad target: ")
+--   ]
+-- errors = []

haskell-experiments/test/Main.hs

@@ -0,0 +1,11 @@
+module Main (main) where
+import Test.Hspec
+
+import qualified Test.OlogsSpec as Ologs
+--import Test.FooSpec
+
+main :: IO ()
+main = hspec $ do
+    describe "Ologs" Ologs.spec
+--    describe "My amazing tests" [ FastLaneSpec FooSpec ]
+

haskell-experiments/test/Test/OlogsSpec.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# HLINT ignore "Use const" #-}
+{-# HLINT ignore "Unused LANGUAGE pragma" #-}
+{-# HLINT ignore "Avoid lambda" #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.OlogsSpec where
+
+import Data.Either (isRight)
+import Ologs
+import Test.Hspec
+
+type MaybeOlog = Either (MakeOlogError Int) (Olog Int)
+
+spec :: Spec
+spec = do
+  describe "olog sanity checks" $ do
+    it "arcs must have a source of a known dot" $
+      let badOlog :: MaybeOlog
+          badOlog =
+            makeOlog [1] [("source", 0, 1)] []
+       in badOlog `shouldBe` Left (UnknownSource "source" 0)
+    it "arcs must have a target of a known dot" $
+      let badOlog :: MaybeOlog
+          badOlog =
+            makeOlog [0] [("source", 0, 1)] []
+       in badOlog `shouldBe` Left (UnknownTarget "source" 1)
+    it "arc is then ok" $
+      let goodOlog :: MaybeOlog
+          goodOlog =
+            makeOlog [0, 1] [("y", 1, 0), ("x", 0, 1)] []
+       in isRight goodOlog `shouldBe` True
+    it "identities can't just say 1 = 1" $
+      let badOlog :: MaybeOlog
+          badOlog =
+            makeOlog [0] [] [([], [])]
+       in badOlog `shouldBe` Left ForbiddenTrivialIdentity
+    it "identities should only use known names" $
+      let badOlog :: MaybeOlog
+          badOlog =
+            makeOlog [0] [] [(["identity"], [])]
+     in badOlog `shouldBe` Left (UnknownArc "identity")
+    it "arcs in lhs of identities join up" $
+      let badOlog :: MaybeOlog
+          badOlog =
+            makeOlog
+              [0, 1, 2]
+              [("0to1", 0, 1), ("1to2", 1, 2), ("0to2", 0, 2), ("1to0", 1, 0)]
+              [(["0to1", "1to2"], ["0to2"])]
+       in badOlog `shouldBe` Left (NonJoiningExpressionLhs ["0to1", "1to2"])
+    it "arcs in rhs of identities join up" $
+      let badOlog :: MaybeOlog
+          badOlog =
+            makeOlog
+              [0, 1, 2]
+              [("0to1", 0, 1), ("1to2", 1, 2), ("0to2", 0, 2), ("1to0", 1, 0)]
+              [(["0to2"], ["0to1", "1to2"])]
+       in badOlog `shouldBe` Left (NonJoiningExpressionRhs ["0to1", "1to2"])
+    it "lhs and rhs of identities have same source and target" $
+      let badOlog :: MaybeOlog
+          badOlog =
+            makeOlog
+              [0, 1, 2]
+              [("0to1", 0, 1), ("1to2", 1, 2), ("0to2", 0, 2), ("1to0", 1, 0)]
+              [(["1to0", "0to1"], ["1to2", "0to1"])]
+       in badOlog `shouldBe` Left (IdentityMismatch ["1to0", "0to1"] ["1to2", "0to1"] (0, 0) (0, 2))
+    it "consistent joined-up identities are ok" $
+      let goodOlog :: MaybeOlog
+          goodOlog =
+            makeOlog
+              [0, 1, 2]
+              [("0to1", 0, 1), ("1to2", 1, 2), ("0to2", 0, 2), ("1to0", 1, 0)]
+              [(["1to2", "0to1"], ["0to2"])]
+       in 
+        case goodOlog of
+          Left err -> expectationFailure $ show err
+          Right _ -> pure ()
+
+-- it "identities should have the same source and target on both sides" $
+-- describe "create a basic olog" $ do
+--   it "the graph olog" $
+--     let -- x :: Int
+--         -- x = 3
+--         graphOlog :: Either String (Olog Int)
+--         graphOlog =
+--           makeOlog [0, 1] [("source", 0, 1), ("target", 1, 0)] []
+--     in do
+--           [7, 8] `shouldBe` [7, 8]
+-- TODO: add test when [] == something that isn't a loop