x-dsp-0.2: tools/mkClass.hs

import           CsMaps
import           CsParser

import           Sound.Csound
import           Control.Arrow ((***))
import           Control.Applicative ((*>), (<*))
import           Control.Monad.Error
import           Control.Monad.State
import           Control.Monad.Writer
import qualified Data.Map as M
import           Data.Maybe
import qualified Data.Set as S
import           Text.Printf
import           Data.Char
import           Data.List (intercalate)

-- create a class description from OpcodeListEntry

-- | the opcodelist has duplicate entries for overloaded opcodes.
-- merge them to single polymorphic variants, collecting information
-- on errors
mergeOpcodeList :: [OpcodeListEntry] -> ([String], [OpcodeListEntry])
mergeOpcodeList = fmap M.elems . foldr fn ([],M.empty)
 where
  fn ocl (errs,mp) =
   let onm = opcodeName ocl
   in case M.lookup onm mp of
        Nothing   -> (errs,M.insert onm ocl mp)
        Just prev -> either (\err' -> (err':errs,mp))
                            (\n' -> (errs,M.insert onm n' mp))
                            (mixOcl ocl prev)


mixOcl :: OpcodeListEntry -> OpcodeListEntry -> Either String OpcodeListEntry
mixOcl a b | opcodeName a == opcodeName b = do
  los <- zipWithM mixLO (ouTypes a) (ouTypes b)
  return $ OpcodeListEntry (opcodeName a) los (zipWith mixL (inTypes a) (inTypes b))
mixOcl a b = throwError "mixOcl called with non-matching entries"

type SpCtx = String -- stub

cap :: String -> String
cap []     = []
cap (a:as) = toUpper a:as

unCap :: String -> String
unCap []     = []
unCap (a:as) = toLower a:as

mkClass :: SpCtx -> OpcodeListEntry -> Writer [String] String
mkClass ctx ole = case (runParseI (inTypes ole), fmap ctxtRepr $ parseOutarg (ouTypes ole)) of
  (Right i, Right o) -> return $ topline i o ++ mainline i o ++ oline i o
  (Left ie, Left oe) -> tell [opc,ie,oe] >> return ""
  (Left ie, _)       -> tell [opc,ie] >> return ""
  (_,       Left oe) -> tell [opc,oe] >> return ""
 where
  opc = let n' = unCap $ opcodeName ole
        in fromMaybe n' $ M.lookup n' invalidNameMap
  topline (invars,inargs,_,reqNum) (hasOut,outarg) =
    printf "class %s %s repr %s%s where\n"
           ("(" ++ intercalate ", " (ctx:addCtxt (opcodeName ole)) ++ ") =>")
           ("Cs" ++ cap opc)
           (getCtxt hasOut)
           (intercalate " " $ map (:[]) invars)
  mainline (invars,inargs,_,reqNum) (hasOut,outarg) =
    printf "  %s ::\n    %s\n"
           opc
           (intercalate "\n    -> " $ (maybe id take reqNum inargs) ++ [outarg])
  oline (invars,inargs,_,reqNum) (hasOut,outarg) =
    maybe "" (const $ printf "  %s' :: %s\n"
                             opc
                             (intercalate "\n    -> " $ inargs ++ [outarg]))
             reqNum

allOps = do
  ops <- runCsound (compile "-d foo.csd" >> newOpcodeList <* cleanup)
  return $ either (error . show) id ops

writeOut fn ctx ops = do
  writeFile fn . intercalate "\n\n" $
    filter (not .null) (exts:mkModule allModName:vals)
  writeFile ("err_" ++ fn) $ intercalate "\n\n" (errs ++ errs1)
 where
  (errs1, ops') = mergeOpcodeList $ filter (not . flip S.member noReuseSet . opcodeName) ops
  (vals,errs) = runWriter $ mapM (mkClass ctx) ops'

exts = "{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}"

mkModule modname =
  "module " ++ modname ++ " where\n\nimport Language.XDsp.Semantics.Core\nimport Language.XDsp.Semantics.CsoundExt.Core\nimport Language.XDsp.Semantics.Extras\nimport Language.XDsp.Semantics.BasicExtensions"

allModName = "Language.XDsp.Semantics.CsoundExt.All"

main = allOps >>= writeOut "allOps.txt" "CsoundClass repr"