From: Mart Lubbers <mart@martlubbers.net>
Date: Tue, 19 Feb 2019 12:52:29 +0000 (+0100)
Subject: tree and format
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=abe49857cf98e3ae8d24d2e1861debabaaacd27e;p=cleanm.git

tree and format
---

diff --git a/.gitignore b/.gitignore
index 58df8c9..5e7605c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,6 @@
 a.out
+index
+format
+flac
 Clean System Files
 *.json
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..ab8aac2
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,13 @@
+CLM?=clm
+CLMFLAGS?=-l -lFLAC
+CLMLIBS?=-IL Platform
+
+BINARIES:=index
+
+all: $(BINARIES)
+
+%: %.icl
+	$(CLM) $(CLMLIBS) $(CLMFLAGS) $* $(OUTPUT_OPTION)
+
+clean:
+	$(RM) -r Clean\ System\ Files a.out $(BINARIES)
diff --git a/format.dcl b/format.dcl
new file mode 100644
index 0000000..c0bd3b2
--- /dev/null
+++ b/format.dcl
@@ -0,0 +1,9 @@
+definition module format
+
+from StdOverloaded import class ==
+from Data.Error import :: MaybeError, :: MaybeErrorString
+
+:: FormatString
+
+instance == FormatString
+parseFormat :: [Char] -> MaybeErrorString FormatString
diff --git a/format.icl b/format.icl
new file mode 100644
index 0000000..506d520
--- /dev/null
+++ b/format.icl
@@ -0,0 +1,51 @@
+implementation module format
+
+import StdEnv
+
+import Data.Func
+import Data.Either
+import Data.Error
+import Data.Functor
+import Data.List
+import Data.Maybe
+import Data.GenEq
+import Control.Applicative
+import Control.Monad
+import Text => qualified join
+import Text.Parsers.Simple.ParserCombinators
+
+:: FormatString :== [Format]
+:: Format
+	= FMTLiteral String
+	| FMTApply FormatFun [Format]
+
+:: FormatFun
+	= FFTag
+
+derive gEq Format, FormatFun
+instance == FormatString where == x y = x === y
+
+format :: [(String, String)] FormatString -> MaybeErrorString String
+format tags f = concat <$> mapM fmt f
+where
+	fmt :: Format -> MaybeErrorString String
+	fmt (FMTLiteral s) = pure s
+	fmt (FMTApply fun args) = case (fun, args) of
+		(FFTag, [tag,alt])
+			= flip fromMaybe o flip lookup tags <$> fmt tag <*> fmt alt
+		(FFTag, _) = Error "`tag` must have exactly two arguments"
+		_ = Error "Unimplemented function"
+
+parseFormat :: [Char] -> MaybeErrorString FormatString
+parseFormat s = either (Error o concat) Ok (parse (some pFormat) s)
+
+pFormat :: Parser Char Format
+pFormat
+	=   FMTApply <$ pToken '$' <*> pFormatFun <* pToken '{' <*> pSepBy pFormat pComma <* pToken '}'
+	<|> FMTLiteral <$> toString <$> some (
+		     pToken '\\' *> pSatisfy (\x->isMember x ['${},'])
+		<|> pSatisfy (\x->not (isMember x ['$[],'])))
+	
+
+pFormatFun :: Parser Char FormatFun
+pFormatFun = FFTag <$ pList (map pToken ['tag'])
diff --git a/index.icl b/index.icl
index 373ed82..d1b4359 100644
--- a/index.icl
+++ b/index.icl
@@ -8,32 +8,29 @@ import System.Directory
 import Text.GenJSON
 import Data.Tree
 
+import format
+
 derive JSONEncode RTree, FileInfo, Tm, MaybeError
 derive JSONDecode RTree, FileInfo, Tm, MaybeError
 
-:: MusicDB :== RTree MusicEntry
-:: MusicEntry =
-	{ fe_filepath   :: !FilePath
-	, fe_fileinfo   :: !MaybeOSError FileInfo
-	, fe_musicentry :: [!Tag!]
-	}
+:: MusicDB =
+	{ mdb_format :: [Format]
+	, mdb_tree   :: RTree
 :: Tag =
 	{ tag_key   :: !String
 	, tag_value :: !String
 	}
 
-index :: MusicDB (RTree (FilePath, MaybeOSError FileInfo)) *World -> *(MusicDB, *World)
-index (RNode mn mcs) (RNode (fp, mfi) fcs) w = (RNode mn mcs, w)
-
 dbfile = "db.json"
 root = "/mnt/data/music"
 
-writeDB db w
-	# (ok, f, w) = fopen dbfile FWriteData w
-	| not ok = abort "Cannot open file\n"
-	# (ok, w) = fclose (f <<< toJSON db) w
-	| not ok = abort "Cannot close file\n"
-	= w
+writeJSON :: a String *World -> (MaybeErrorString (), *World) | JSONEncode{|*|} a
+writeJSON obj fp w
+	# (ok, f, w) = fopen fp FWriteData w
+	| not ok = (Error ("Cannot open " +++ fp +++ " as file"), w)
+	# (ok, w) = fclose (f <<< toJSON obj) w
+	| not ok = (Error ("Cannot close " +++ fp), w)
+	= (Ok (), w)
 
 Start w
 	# (mfi, w) = getFileInfo root w
@@ -41,5 +38,4 @@ Start w
 	# (Ok fi) = mfi
 	| not fi.directory = abort "Root is not a directory\n"
 	# (tree, w) = readDirectoryTree root Nothing w
-	# (db, w) = index (RNode {fe_filepath=root,fe_fileinfo=mfi,fe_musicentry=[!!]} []) tree w
-	= writeDB tree w
+	= writeJSON tree dbfile w