tree and format

diff --git a/.gitignore b/.gitignore
index 58df8c9..5e7605c 100644 (file)
--- 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 (file)
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 (file)
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 (file)
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 (file)
--- 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