refactor library

10 files changed, 1 insertions, 649 deletions

diff --git a/app/Debug.hs b/app/Debug.hs
deleted file mode 100644
index 3499e02..0000000
--- a/app/Debug.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Debug
-  ( debug,
-  )
-where
-
-import Debug.Trace (trace)
-import Text.Printf (printf)
-
-debug :: Show a => String -> a -> a
-debug s x = trace (printf "%s: %s" s (show x)) x
diff --git a/app/Exception.hs b/app/Exception.hs
deleted file mode 100644
index 0cccf5b..0000000
--- a/app/Exception.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Exception
-  ( DecodeException (DecodeException),
-    DuplicateField (DuplicateField),
-    ParseError (ParseError),
-  )
-where
-
-import Control.Exception (Exception)
-
-data DecodeException = DecodeException
-  deriving (Show)
-
-instance Exception DecodeException
-
-data DuplicateField = DuplicateField String
-  deriving (Show)
-
-instance Exception DuplicateField
-
-data ParseError = ParseError String
-  deriving (Show)
-
-instance Exception ParseError
diff --git a/app/Main.hs b/app/Main.hs
index 7bf67ba..5574afa 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -5,7 +5,7 @@ where
 
 import Data.Aeson qualified as J
 import Data.ByteString.Lazy.Char8 qualified as LB
-import Query qualified as Q
+import Store qualified as Q
 import System.Directory (setCurrentDirectory)
 import Text.Printf (printf)
 
diff --git a/app/Query.hs b/app/Query.hs
deleted file mode 100644
index 140d0f1..0000000
--- a/app/Query.hs
+++ /dev/null
@@ -1,134 +0,0 @@
-module Query
-  ( module Query.Type,
-    query,
-  )
-where
-
-import Control.Exception (throw)
-import Data.Aeson qualified as J
-import Data.Aeson.Key qualified as JK
-import Data.Aeson.KeyMap qualified as JM
-import Data.List (foldl', isSuffixOf)
-import Data.List.NonEmpty qualified as N
-import Data.Maybe (fromMaybe)
-import Data.Vector qualified as V
-import Exception (DecodeException (DecodeException))
-import Query.Parser ()
-import Query.Printer ()
-import Query.Record
-import Query.Type
-import Store qualified as S
-import System.FilePath ((</>))
-
-query :: Query -> IO [J.Value]
-query (Select fs c js es w) = do
-  c' <-
-    mapM (fmap (fromValue c) . decodeFile . (c </>)) =<< ls c
-  js' <-
-    mapM
-      ( \(JoinClause t c w) ->
-          fmap (\j' -> JoinClause t (map (fromValue c) j') w) . mapM (decodeFile . (c </>))
-            =<< ls c
-      )
-      js
-  es' <-
-    mapM
-      ( \(EmbedClause c w) ->
-          fmap (\e' -> EmbedClause (fromValue c e') w) . mapM (decodeFile . (c </>))
-            =<< ls c
-      )
-      es
-  pure $ map (Query.select fs) $ where_ w $ embeds es' $ joins js' c'
-  where
-    ls c =
-      filter (not . (isSuffixOf "/"))
-        <$> S.withStore "." "HEAD" do
-          S.listDirectory c
-
-embeds ::
-  EmbedClauses (Record [J.Value]) ->
-  [Records J.Value] ->
-  [Records J.Value]
-embeds = flip (foldl' embed)
-
-embed ::
-  [Records J.Value] ->
-  EmbedClause (Record [J.Value]) ->
-  [Records J.Value]
-embed vss (EmbedClause (Record c es) w) =
-  map
-    ( \vs ->
-        vs
-          ++ [ fromValue
-                 c
-                 ( J.Object
-                     ( JM.singleton
-                         (JK.fromString c)
-                         ( J.Array
-                             ( V.fromList
-                                 [ e
-                                   | e <- es,
-                                     satisfies w (vs ++ [Record c e])
-                                 ]
-                             )
-                         )
-                     )
-                 )
-             ]
-    )
-    vss
-
-joins ::
-  JoinClauses (Records J.Value) ->
-  [Record J.Value] ->
-  [Records J.Value]
-joins js (map (: []) -> vss) = foldl' join vss js
-
-join ::
-  [Records J.Value] ->
-  JoinClause (Records J.Value) ->
-  [Records J.Value]
-join vss (JoinClause JoinLeft js w) =
-  concatMap
-    ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
-        [] -> [vs]
-        vs' -> vs'
-    )
-    vss
-join vss (JoinClause JoinRight js w) =
-  concatMap
-    ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
-        [] -> [[j]]
-        vs' -> vs'
-    )
-    js
-join vss (JoinClause JoinFull js w) =
-  concatMap
-    ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
-        [] -> [vs]
-        vs' -> vs'
-    )
-    vss
-    ++ concatMap
-      ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
-          [] -> [[j]]
-          _ -> []
-      )
-      js
-
-select :: FieldSelector -> Records J.Value -> J.Value
-select All vs = disjointUnions (map toValue vs)
-select (Only fs) vs = Query.Record.select (N.toList fs) vs
-
-where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value]
-where_ w = filter (satisfies w)
-
-satisfies :: Maybe WhereClause -> Records J.Value -> Bool
-satisfies Nothing _ = True
-satisfies (Just (And ws)) vs = all (\w -> satisfies (Just w) vs) ws
-satisfies (Just (Or ws)) vs = any (\w -> satisfies (Just w) vs) ws
-satisfies (Just (Where (Eq f g))) vs = lookups f vs == lookups g vs
-
-decodeFile :: J.FromJSON a => Collection -> IO a
-decodeFile fp = S.withStore "." "HEAD" do
-  fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp
diff --git a/app/Query/Field.hs b/app/Query/Field.hs
deleted file mode 100644
index cdb977a..0000000
--- a/app/Query/Field.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Query.Field
-  ( Field (..),
-    toString,
-    prefix,
-  )
-where
-
-import Data.Aeson qualified as J
-import Data.Aeson.Key qualified as JK
-import Data.Aeson.KeyMap qualified as JM
-import Data.List (intercalate)
-import Data.List.NonEmpty qualified as N
-import Data.Text qualified as T
-
-data Field
-  = Qualified Collection (N.NonEmpty T.Text)
-  | Unqualified (N.NonEmpty T.Text)
-  deriving (Show)
-
-toString :: Field -> String
-toString (Qualified c ks) = intercalate "." (c : map T.unpack (N.toList ks))
-toString (Unqualified ks) = intercalate "." (map T.unpack (N.toList ks))
-
-type Collection = FilePath
-
-prefix :: Field -> J.Value -> J.Value
-prefix (Qualified c ks) = prefix' (T.pack c : N.toList ks)
-prefix (Unqualified ks) = prefix' (N.toList ks)
-
-prefix' :: [T.Text] -> J.Value -> J.Value
-prefix' ks v =
-  foldr ((J.Object .) . JM.singleton) v (map JK.fromText ks)
diff --git a/app/Query/Parser.hs b/app/Query/Parser.hs
deleted file mode 100644
index f2012e2..0000000
--- a/app/Query/Parser.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Query.Parser () where
-
-import Control.Exception (throw)
-import Control.Monad (void)
-import Control.Monad.Combinators.NonEmpty qualified as PN
-import Data.Char (isSpace)
-import Data.List.NonEmpty qualified as N
-import Data.String (IsString (fromString))
-import Data.Text qualified as T
-import Data.Void (Void)
-import Exception (ParseError (ParseError))
-import Query.Type
-import Text.Megaparsec qualified as P
-import Text.Megaparsec.Char qualified as P
-import Text.Megaparsec.Char.Lexer qualified as P
-
-instance IsString Query where
-  fromString =
-    either (throw . ParseError . P.errorBundlePretty @String @Void) id
-      . P.parse parser ""
-    where
-      parser = do
-        void $ P.many P.space1
-        select
-        fs <- fieldSelector
-        from
-        c <- collection
-        js <- joinClauses
-        es <- embedClauses
-        w <- P.optional do
-          where_
-          whereClause
-        P.eof
-        pure $ Select fs c js es w
-
-      lexeme :: P.Parsec Void String a -> P.Parsec Void String a
-      lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace
-
-      and = void $ lexeme (P.string "AND")
-      comma = void $ lexeme (P.string ",")
-      embed = void $ lexeme (P.string "EMBED")
-      eq = void $ lexeme (P.string "==")
-      from = void $ lexeme (P.string "FROM")
-      on = void $ lexeme (P.string "ON")
-      or = void $ lexeme (P.string "OR")
-      select = void $ lexeme (P.string "SELECT")
-      where_ = void $ lexeme (P.string "WHERE")
-
-      collection = lexeme $ P.takeWhile1P (Just "collection") (not . isSpace)
-
-      joinClauses = P.many joinClause
-
-      joinClause = do
-        t <- joinType
-        c <- collection
-        w <- P.optional do
-          on
-          whereClause
-        pure $ JoinClause t c w
-
-      embedClauses = P.many embedClause
-
-      embedClause = do
-        embed
-        c <- collection
-        w <- P.optional do
-          on
-          whereClause
-        pure $ EmbedClause c w
-
-      whereClause =
-        P.choice
-          [ P.try (And . map Where <$> P.sepBy1 comparison and),
-            P.try (Or . map Where <$> P.sepBy1 comparison or),
-            Where <$> comparison
-          ]
-
-      comparison = do
-        a <- field
-        eq
-        b <- field
-        pure $ Eq a b
-
-      fieldSelector =
-        P.choice
-          [ do
-              void $ lexeme $ P.string "*"
-              pure All,
-            do
-              Only <$> PN.sepBy1 field comma
-          ]
-
-      field :: P.Parsec Void String Field
-      field =
-        lexeme . P.choice $
-          [ P.try
-              do
-                Qualified
-                  <$> (fieldPart <* P.string ".")
-                  <*> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")),
-            do
-              Unqualified
-                <$> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string "."))
-          ]
-
-      fieldPart :: P.Parsec Void String String
-      fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.')
-
-      joinType :: P.Parsec Void String JoinType
-      joinType =
-        P.choice
-          [ do
-              void $ lexeme (P.string "LEFT")
-              void $ lexeme (P.string "JOIN")
-              pure JoinLeft,
-            do
-              void $ lexeme (P.string "RIGHT")
-              void $ lexeme (P.string "JOIN")
-              pure JoinRight,
-            do
-              void $ lexeme (P.string "FULL")
-              void $ lexeme (P.string "JOIN")
-              pure JoinFull
-          ]
diff --git a/app/Query/Printer.hs b/app/Query/Printer.hs
deleted file mode 100644
index e43b7d0..0000000
--- a/app/Query/Printer.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Query.Printer () where
-
-import Data.List (intercalate)
-import Data.List.NonEmpty qualified as N
-import Data.Maybe (catMaybes, mapMaybe)
-import Query.Field
-import Query.Type
-
-instance Show Query where
-  show (Select fs c js es w) =
-    intercalate " " $
-      catMaybes $
-        [ Just "SELECT",
-          Just (showFieldSelector fs),
-          Just "FROM",
-          Just (showCollection c),
-          showJoinClauses js,
-          showEmbedClauses es,
-          showWhereClause w
-        ]
-    where
-      showFieldSelector All = "*"
-      showFieldSelector (Only (N.toList -> fs)) =
-        intercalate ", " (map showField fs)
-      showField = Query.Field.toString
-      showCollection c = c
-      showJoinClauses js = case map showJoinClause js of
-        [] -> Nothing
-        xs -> Just (intercalate " " xs)
-      showJoinClause (JoinClause t c w) =
-        intercalate " " $
-          catMaybes $
-            [ Just (showJoinType t),
-              Just (showCollection c),
-              Just "ON",
-              showWhereClause w
-            ]
-      showJoinType JoinLeft = "LEFT JOIN"
-      showJoinType JoinRight = "RIGHT JOIN"
-      showJoinType JoinFull = "FULL JOIN"
-      showEmbedClauses js = case map showEmbedClause js of
-        [] -> Nothing
-        xs -> Just (intercalate " " xs)
-      showEmbedClause (EmbedClause c w) =
-        intercalate " " $
-          catMaybes $
-            [ Just "EMBED",
-              Just (showCollection c),
-              Just "ON",
-              showWhereClause w
-            ]
-      showWhereClause = showWhereClauseWith id
-      showWhereClause' = showWhereClauseWith (\x -> "(" <> x <> ")")
-      showWhereClauseWith _ Nothing = Nothing
-      showWhereClauseWith wrap (Just (And ws)) = Just (wrap (intercalate "AND" (mapMaybe (showWhereClause' . Just) ws)))
-      showWhereClauseWith wrap (Just (Or ws)) = Just (wrap (intercalate "OR" (mapMaybe (showWhereClause' . Just) ws)))
-      showWhereClauseWith _ (Just (Where p)) = Just (showComparison p)
-      showComparison (Eq a b) = intercalate " " [showField a, "==", showField b]
diff --git a/app/Query/Record.hs b/app/Query/Record.hs
deleted file mode 100644
index b1b3329..0000000
--- a/app/Query/Record.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-module Query.Record
-  ( Record (..),
-    fromValue,
-    toValue,
-    lookup,
-    Records,
-    lookups,
-    select,
-    disjointUnion,
-    disjointUnions,
-  )
-where
-
-import Control.Exception (throw)
-import Data.Aeson qualified as J
-import Data.Aeson.Key qualified as JK
-import Data.Aeson.KeyMap qualified as JM
-import Data.List (foldl')
-import Data.List.NonEmpty qualified as N
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Text qualified as T
-import Exception (DuplicateField (DuplicateField))
-import Query.Field
-import Prelude hiding (lookup)
-
-data Record a
-  = Record Collection a
-  deriving (Show, Eq)
-
-type Collection = FilePath
-
-fromValue :: Collection -> a -> Record a
-fromValue = Record
-
-toValue :: Record a -> a
-toValue (Record _ v) = v
-
-lookup :: Field -> Record J.Value -> Maybe J.Value
-lookup (Unqualified ks) (Record _ v) =
-  lookup' (N.toList ks) v
-lookup (Qualified c' ks) (Record c v)
-  | c' == c = lookup' (N.toList ks) v
-  | otherwise = Nothing
-
-lookup' :: [T.Text] -> J.Value -> Maybe J.Value
-lookup' [] v = Just v
-lookup' (k : ks) (J.Object kvs) =
-  lookup' ks =<< JM.lookup (JK.fromText k) kvs
-
-type Records a = [Record a]
-
-lookups :: Field -> Records J.Value -> Maybe J.Value
-lookups f rs =
-  case mapMaybe (lookup f) rs of
-    [] -> Nothing
-    [v] -> Just v
-    (_ : _) -> throw (DuplicateField (toString f))
-
-select :: [Field] -> Records J.Value -> J.Value
-select fs rs =
-  foldl'
-    union
-    (J.Object JM.empty)
-    (map (\f -> prefix f ((fromMaybe J.Null (lookups f rs)))) fs)
-
-union :: J.Value -> J.Value -> J.Value
-union (J.Object r) (J.Object s) = J.Object (JM.unionWith union r s)
-
-disjointUnion :: J.Value -> J.Value -> J.Value
-disjointUnion (J.Object r) (J.Object s) =
-  J.Object (JM.unionWithKey disjointUnion' r s)
-
-disjointUnion' :: JK.Key -> J.Value -> J.Value -> J.Value
-disjointUnion' _ (J.Object r) (J.Object s) =
-  J.Object (JM.unionWithKey disjointUnion' r s)
-disjointUnion' k _ _ =
-  throw (DuplicateField (JK.toString k))
-
-disjointUnions :: [J.Value] -> J.Value
-disjointUnions = foldl' disjointUnion (J.Object JM.empty)
diff --git a/app/Query/Type.hs b/app/Query/Type.hs
deleted file mode 100644
index d27106f..0000000
--- a/app/Query/Type.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-module Query.Type
-  ( module Query.Field,
-    module Query.Record,
-    Collection,
-    Comparison (..),
-    EmbedClause (..),
-    EmbedClauses,
-    FieldSelector (..),
-    JoinClause (..),
-    JoinClauses,
-    JoinType (..),
-    Query (..),
-    WhereClause (..),
-  )
-where
-
-import Data.List.NonEmpty qualified as N
-import Query.Field
-import Query.Record
-
-data Query
-  = Select
-      FieldSelector
-      Collection
-      (JoinClauses FilePath)
-      (EmbedClauses FilePath)
-      (Maybe WhereClause)
-
-data FieldSelector
-  = All
-  | Only (N.NonEmpty Field)
-  deriving (Show)
-
-type Collection = FilePath
-
-type JoinClauses a = [JoinClause a]
-
-data JoinClause a
-  = JoinClause JoinType a (Maybe WhereClause)
-  deriving (Show)
-
-data JoinType
-  = JoinLeft
-  | JoinRight
-  | JoinFull
-  deriving (Show)
-
-type EmbedClauses a = [EmbedClause a]
-
-data EmbedClause a
-  = EmbedClause a (Maybe WhereClause)
-  deriving (Show)
-
-data WhereClause
-  = And [WhereClause]
-  | Or [WhereClause]
-  | Where Comparison
-  deriving (Show)
-
-data Comparison
-  = Eq Field Field
-  deriving (Show)
diff --git a/app/Store.hs b/app/Store.hs
deleted file mode 100644
index 3a899b6..0000000
--- a/app/Store.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-module Store
-  ( withStore,
-    listDirectory,
-    readFile,
-  )
-where
-
-import Control.Arrow (first)
-import Control.Exception (Exception, finally)
-import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)
-import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
-import Control.Monad.State (MonadState, StateT, evalStateT, get)
-import Control.Monad.Trans (MonadIO, MonadTrans, lift)
-import Data.ByteString qualified as B
-import Data.ByteString.Lazy qualified as LB
-import Data.ByteString.UTF8 qualified as B
-import Data.List (isPrefixOf, sort)
-import Data.Tagged (Tagged (Tagged))
-import Data.Text qualified as T
-import Git qualified as G
-import Git.Libgit2 qualified as GB
-import System.FilePath (addTrailingPathSeparator, hasDrive, joinDrive, makeRelative, normalise, splitPath)
-import Prelude hiding (readFile)
-
-newtype StoreT m a = StoreT
-  { runStoreT :: StateT GB.OidPtr (ReaderT GB.LgRepo m) a
-  }
-  deriving
-    ( Applicative,
-      Functor,
-      Monad,
-      MonadReader GB.LgRepo,
-      MonadState GB.OidPtr,
-      MonadCatch,
-      MonadThrow,
-      MonadIO
-    )
-
-instance MonadTrans StoreT where
-  lift = StoreT . lift . lift
-
-class MonadStore m where
-  getCommitOid :: m (G.CommitOid GB.LgRepo)
-  getRepository :: m GB.LgRepo
-
-instance Monad m => MonadStore (StoreT m) where
-  getCommitOid = Tagged <$> get
-  getRepository = ask
-
-type StoreM = StoreT IO
-
-withStore :: FilePath -> G.RefName -> StoreM a -> IO a
-withStore repoPath ref action = do
-  repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath}
-  Just cid <- G.runRepository GB.lgFactory repo (G.resolveReference ref)
-  runReaderT (evalStateT (runStoreT action) cid) repo
-    `finally` G.runRepository GB.lgFactory repo G.closeRepository
-
-listDirectory :: FilePath -> StoreM [FilePath]
-listDirectory dir' = do
-  cid <- getCommitOid
-  repo <- getRepository
-  lift $ G.runRepository GB.lgFactory repo $ do
-    let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir'
-        n = length (splitPath dir)
-    tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid
-    sort
-      . map (makeRelative dir)
-      . filter ((== n + 1) . length . splitPath)
-      . filter (isPrefixOf (addTrailingPathSeparator dir))
-      . map fst
-      . map
-        ( \e ->
-            case snd e of
-              G.BlobEntry _ _ -> e
-              G.CommitEntry _ -> error "XXX commit entry"
-              G.TreeEntry _ -> first addTrailingPathSeparator e
-        )
-      . map (first (("/" <>) . B.toString))
-      <$> G.listTreeEntries tree
-
-data DoesNotExist = DoesNotExist String FilePath
-  deriving (Show)
-
-instance Exception DoesNotExist
-
-data InappropriateType = InappropriateType String FilePath
-  deriving (Show)
-
-instance Exception InappropriateType
-
-class Readable a where
-  readFile :: FilePath -> StoreM a
-
-instance Readable T.Text where
-  readFile = readFile' G.catBlobUtf8
-
-instance Readable B.ByteString where
-  readFile = readFile' G.catBlob
-
-instance Readable LB.ByteString where
-  readFile = readFile' G.catBlobLazy
-
-readFile' ::
-  (G.BlobOid GB.LgRepo -> ReaderT GB.LgRepo IO a) ->
-  FilePath ->
-  StoreM a
-readFile' cat fp = do
-  cid <- getCommitOid
-  repo <- getRepository
-  lift $ G.runRepository GB.lgFactory repo do
-    tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid
-    maybe
-      (throwM (DoesNotExist "readFile" fp))
-      ( \e ->
-          case e of
-            G.BlobEntry bid _ -> cat bid
-            G.CommitEntry _ -> error "XXX commit entry"
-            G.TreeEntry _ -> throwM (InappropriateType "readFile" fp)
-      )
-      =<< G.treeEntry tree (B.fromString fp)