x-dsp-0.2: tools/mkOp.hs

module Main (main) where

import           CsMaps
import           CsParser

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

foldM1 f [] = error "foldM1 called on empty list"
foldM1 f (x:xs) = foldM f x xs

fromRight (Right val) = val
fromRight n           = error $ "fromRight called on Left" ++ show n

-- scheme for handling instances:
-- group all opcodes by name and determine var positions
-- group opcodes by output (a,k,i, other)
-- merge each group, separate instance for each output type
-- k-inputs can be k- or i-, use the KVar class

-- | partition opcode list into a list of
--  (name, fully-merged opcode, opcodes merged by outarg)
partitionOutarg :: [OpcodeListEntry]
  -> ([String], [(String, OpcodeListEntry, [(OType,OpcodeListEntry)])])
partitionOutarg = partitionEithers . map mungeTup . M.assocs . foldr f M.empty
 where
  -- make map of (name) to list of opcodes
  f ocl = M.insertWith (++) (opcodeName ocl) [ocl]
  g ocl = M.insertWith (++) (either (const SS) id . parseOutarg $ ouTypes ocl) [ocl]
  mungeTup (nm, ocls) = do
    fullMerge <- foldM1 mixOcl ocls
    let (chk,oMap) = M.mapEither (foldM1 mixOcl) $ foldr g M.empty ocls
    when (not $ M.null chk) (error "chk map isn't empty, shouldn't happen")
    return (nm, fullMerge, M.assocs oMap)

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


-- ops' :: (Name, MergedOp, [(OType, MergedOp)])
-- for each MergedOp, get the tyvar positions
-- then write an instance for each OType, filling in the tyvars

mkInstance :: String -> OpcodeListEntry -> (OType, OpcodeListEntry)
  -> Writer [String] String
mkInstance _ flmrg (otype, ole) = 
 case (getInArgTyVars (inTypes flmrg), parseOutarg (ouTypes flmrg)) 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
  lookupInTyp (pos,vnm) = either
                          (\nm' -> Left $ nm' ++ [vnm])
                          (Right)
                          (inArgInstanceInfo $ (inTypes ole) !! pos)
  tyVars (pos,vnm) = either (const [vnm])
                            id
                            (inArgInstanceInfo $ (inTypes ole) !! pos)
  -- inargs :: [(VarPos, VarName)]
  topline (tnum,inargs,reqNum) fmOt =
    printf "instance %s %s (S n) %s where\n"
           (if null allHd then ""
             else printf "(%s) =>" (intercalate ", " allHd))
           (qualifyName $ "Cs" ++ cap opc)
           allDecl
     where
       (inHd, _) = partitionEithers $ map lookupInTyp inargs
       -- if the instance outtype needs a context, provide it
       allHd = maybe inHd ((:inHd) . fst) (instrCtx otype)
       inDecls = map tyVars inargs
       allDecl = unwords $ if oHasCtxt fmOt then (monoCtxt otype:inDecls) else inDecls
  mainline (tnum,inargs,reqNum) _ =
    printf "  %s = mkOp%d \"%s\"\n" opc (fromMaybe tnum reqNum) opc
  oline (tnum,inargs,reqNum) _ =
    maybe "" (const $ printf "  %s' = mkOp%d \"%s\"\n" opc tnum opc) 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) $ concat vals
  writeFile ("err_" ++ fn) $ intercalate "\n\n" (errs ++ errs1)
 where
  -- ops' :: [ (Name, MergedOp, [(OType, MergedOp)]) ]
  (errs1, ops') = partitionOutarg $ filter (not . flip S.member noReuseSet . opcodeName) ops
  (vals,errs) = runWriter $ mapM (\(a,b,c) -> mapM (mkInstance a b) c) ops'

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