x-dsp-0.2: tools/CsParser.hs

module CsParser where

import           Control.Monad.Error
import           Control.Monad.State
import           Control.Monad.Writer
import           Data.List (intercalate)
import           Data.Maybe

-- http://www.perceptionfactory.com/csound/csound5extending.html
-- there's got to be a better way to encode this.  Maybe something like
-- a partial order?
mixL  a   b | a == b = a
mixL 'i' 'k' = 'k'
mixL 'i' 'a' = 'x'
mixL 'i' 'x' = 'x'
mixL 'i' 'S' = 'x'
mixL 'k' 'i' = 'k'
mixL 'k' 'a' = 'x'
mixL 'k' 'x' = 'x'
mixL 'k' 'S' = 'x'
mixL 'a' 'i' = 'x'
mixL 'a' 'k' = 'x'
mixL 'a' 'x' = 'x'
mixL 'a' 'S' = 'x'
mixL 'x' 'i' = 'x'
mixL 'x' 'k' = 'x'
mixL 'x' 'a' = 'x'
mixL 'S' 'i' = 'x'
mixL 'S' 'k' = 'x'
mixL 'S' 'a' = 'x'
mixL 'S' 'x' = 'x'
mixL _   _   = '*' -- don't have any means to handle other intypes yet.

-- | polyvar codes:
-- s : perf-time, a+k
-- c : control-time, k+i+S
-- v : any-time, a+k+i+S
mixLO :: Char -> Char -> Either String Char
mixLO 'v'  _  = return 'v'
mixLO  _  'v' = return 'v'
mixLO 's' 'i' = return 'v'
mixLO 's' 'c' = return 'v'
mixLO 's' 'S' = return 'v'
mixLO 's'  _  = return 's'
mixLO 'c' 's' = return 'v'
mixLO 'c' 'a' = return 'v'
mixLO 'c'  _  = return 'c' -- c,i,k,S
mixLO 'a' 'i' = return 'v'
mixLO 'a' 'k' = return 's'
mixLO 'a' 's' = return 's'
mixLO 'a' 'c' = return 'v'
mixLO 'a' 'S' = return 'v'
mixLO 'k' 'i' = return 'c'
mixLO 'k' 'a' = return 's'
mixLO 'k' 's' = return 's'
mixLO 'k' 'c' = return 'c'
mixLO 'k' 'S' = return 'c'
mixLO 'i' 'k' = return 'c'
mixLO 'i' 'a' = return 'v'
mixLO 'i' 'c' = return 'c'
mixLO 'i' 's' = return 'v'
mixLO 'i' 'S' = return 'c'
mixLO 'S' 'i' = return 'c'
mixLO 'S' 'k' = return 'c'
mixLO 'S' 'a' = return 'v'
mixLO 'S' 'c' = return 'c'
mixLO 'S' 's' = return 'v'
mixLO a b
  | a == b    = return a
  | otherwise = throwError $ "mixLO unexpected combination: " ++ [a,' ',b]

type ArgCtx r = StateT (Int,((Int,Int), Bool)) (Writer [String]) r

getLbl = do
  (x,b) <- get
  put (succ x,b)
  return (toEnum x)

incr = do
  (x,((i1,i2),b)) <- get
  if not b
    then put (x,((succ i1,i2),b))
    else put (x,((i1,succ i2),b))

setOpt = do
  (x,((i1,i2),b)) <- get
  if not b
    then put (x,((succ i1,i2),True))
    else put (x,((i1,succ i2),True))

tellS s = tell [s] >> return Nothing

optIRateInargs = "opqvjh"

parseInarg :: Char -> ArgCtx (Maybe String)
parseInarg 'a' = incr >> return (Just "ASig repr")
parseInarg 'k' = incr >> return (Just "KSig repr")
parseInarg 'i' = incr >> return (Just "INum repr")
parseInarg 'f' = incr >> return (Just "FSig repr")
parseInarg 'O' = setOpt >> getLbl >>= \l -> return $
  Just ([l]) -- optional i or k var
parseInarg 'p' = setOpt >> return (Just "INum repr")
parseInarg 'S' = incr >> return (Just "VString repr")
parseInarg 'T' = incr >> return (Just "VString repr") -- a file, which can either be a file name or a number (e.g. pvoc.nnn)
parseInarg 'x' = incr >> getLbl >>= \l -> return $
  Just [l] -- i or k var
parseInarg 'm' = incr >> return (Just "[INum repr]")
parseInarg 'M' = incr >> getLbl >>= \l -> return (Just $ "[" ++ [l] ++ "]")
parseInarg 'N' = incr >> return
  (Just "[(INum repr, INum repr)]")
parseInarg 'y' = incr >> return (Just "[ASig repr]")
parseInarg 'z' = incr >> return (Just "[KSig repr]")
parseInarg 'Z' = incr >> return (Just "[(KSig repr, ASig repr)]")
parseInarg c
  | c `elem` optIRateInargs = setOpt >> return (Just "INum repr")
parseInarg z   = tellS $ "unknown inarg: " ++ [z]

inargLbls :: Int -> Char -> ArgCtx (Maybe Int)
inargLbls i 'O' = parseInarg 'O' >> return (Just i)
inargLbls i 'x' = parseInarg 'x' >> return (Just i)
inargLbls i 'M' = parseInarg 'M' >> return (Just i)
inargLbls i c   = parseInarg c   >> return Nothing

-- | Left if in the instance head, Right if in the decl.
inArgInstanceInfo :: Char -> Either String String
inArgInstanceInfo 'a' = Right "(ASig (S n))"
inArgInstanceInfo 'k' = Right "(KSig (S n))"
inArgInstanceInfo 'i' = Right "(INum (S n))"
inArgInstanceInfo 'f' = Right "(FSig (S n))"
inArgInstanceInfo 'o' = Right "(INum (S n))"
inArgInstanceInfo 'O' = Left  "KVar "
inArgInstanceInfo 'p' = Right "(INum (S n))"
inArgInstanceInfo 'S' = Right "(VString (S n))"
inArgInstanceInfo 'T' = Right "(VString (S n))"
inArgInstanceInfo 'x' = Left  "Varable "
inArgInstanceInfo 'm' = Right "[INum (S n)]"
inArgInstanceInfo 'M' = Left  "Varable "
inArgInstanceInfo 'N' = Right "[(INum (S n), INum (S n))]"
inArgInstanceInfo 'y' = Right "[ASig (S n)]"
inArgInstanceInfo 'z' = Right "[KSig (S n)]"
inArgInstanceInfo 'Z' = Right "[(KSig (S n), ASig (S n))]"
inArgInstanceInfo _   = error "invalid inArg in 'inArgInstanceInfo'"

-- | modifications that change the number of inargs, must come before
--   other manipulations of inargs
preMungeInarg :: String -> String
preMungeInarg = concatMap f
 where
  f 'n' = "iN"
    -- convert an odd-numbered list to a required arg and even-numbered list
  f c   = [c]

-- | for an inarg, calc.
-- (totalNumArgs, [VarPos (0ix), VarName], Maybe reqNum)
getInArgTyVars :: String -> Either String (Int, [(Int,Char)], Maybe Int)
getInArgTyVars instrng' =
  either (Left)
         (\(tyvars,_,tnum,mreq) ->
             Right $ (tnum,zip (catMaybes mres) tyvars,mreq))
         (runParseI instrng)
 where
  instrng = preMungeInarg instrng'
  ((mres, _), _) =
    runWriter $ runStateT (mapM (uncurry inargLbls) $ zip [0..] instrng)
                          (fromEnum 'a', ((-1,-1), False))
  

runParseI :: String -> Either String ([Char], [String], Int, Maybe Int) -- (type variables, args, totalnum, maybe number of required args)
runParseI instrng' =
  maybe (Left $ intercalate "\n\t" (instrng:errS))
        (\resstrn -> Right
                     (['a' .. toEnum (lastLbl-1)]
                     ,resstrn
                     ,numReq+numOpt+2
                     ,if hasOpts then Just numReq else Nothing))
        (sequence mres)
 where
  instrng = preMungeInarg instrng'
  ((mres, (lastLbl,((numReq,numOpt), hasOpts))), errS) =
    runWriter $ runStateT (mapM parseInarg instrng)
                          (fromEnum 'a', ((-1,-1), False))


parseOutarg :: String -> Either String OType
parseOutarg ""  = Right U
parseOutarg "a" = Right A
parseOutarg "k" = Right K
parseOutarg "i" = Right I
parseOutarg "f" = Right F
parseOutarg "ik" = Right IK
parseOutarg "ki" = Right KI
parseOutarg "kk" = Right KK
parseOutarg "ff" = Right FF
parseOutarg "aa" = Right AA
parseOutarg "ak" = Right AK
parseOutarg "kkk"  = Right KKK
parseOutarg "aaa"  = Right AAA
parseOutarg "kkkk" = Right KKKK
parseOutarg "aaaa" = Right AAAA
parseOutarg "iiii" = Right IIII
parseOutarg "c" = Right C
parseOutarg "v" = Right V
parseOutarg "s" = Right S
parseOutarg "ss" = Right SS
parseOutarg "S" = Right Str
parseOutarg arg
 | arg == replicate (length arg) 'm' = Right MA
 | otherwise                         = Left $ "can't parse outarg: " ++ arg

data OType =
   A
 | K
 | I
 | F
 | U
 | IK
 | KI
 | KK
 | FF
 | AA
 | AK
 | AAA
 | KKK
 | AAAA
 | KKKK
 | IIII
 | C
 | V
 | S
 | SS
 | Str
 | MA
 deriving (Eq, Show, Read, Ord, Enum)

data OCtxt = OCtxt {
  var :: Bool
 ,nat :: Bool }
 deriving (Eq, Show)

hasOCtxt (OCtxt b1 b2) = b1 || b2

nullCtxt = OCtxt False False
outCtxt  = OCtxt True  False
natCtxt  = OCtxt False True

getCtxt (OCtxt False False) = ""
getCtxt (OCtxt True  False) = "out "
getCtxt (OCtxt False  True) = "d "
getCtxt (OCtxt True   True) = "out d "

-- | convert OType to a ctxtRepr (for mkClass)
ctxtRepr U  = (nullCtxt, "repr ()")
ctxtRepr A = (nullCtxt, "repr (ASig repr)")
ctxtRepr K = (nullCtxt, "repr (KSig repr)")
ctxtRepr I = (nullCtxt, "repr (INum repr)")
ctxtRepr F = (nullCtxt, "repr (FSig repr)")
ctxtRepr IK = (nullCtxt, "repr (INum repr, KSig repr)")
ctxtRepr KI = (nullCtxt, "repr (KSig repr, INum repr)")
ctxtRepr KK = (nullCtxt, "repr (KSig repr, KSig repr)")
ctxtRepr FF = (nullCtxt, "repr (FSig repr, FSig repr)")
ctxtRepr AA = (nullCtxt, "repr (ASig repr, ASig repr)")
ctxtRepr AK = (nullCtxt, "repr (ASig repr, KSig repr)")
ctxtRepr AAA = (nullCtxt, "repr (ASig repr, ASig repr, ASig repr)")
ctxtRepr KKK = (nullCtxt, "repr (KSig repr, KSig repr, KSig repr)")
ctxtRepr AAAA = (nullCtxt, "repr (ASig repr, ASig repr, ASig repr, ASig repr)")
ctxtRepr KKKK = (nullCtxt, "repr (KSig repr, KSig repr, KSig repr, KSig repr)")
ctxtRepr IIII = (nullCtxt, "repr (INum repr, INum repr, INum repr, INum repr)")
ctxtRepr MA   = (natCtxt, "repr (TList d (ASig repr))")
ctxtRepr S    = (outCtxt, "repr out")
ctxtRepr V    = (outCtxt, "repr out")
ctxtRepr C    = (outCtxt, "repr out")
ctxtRepr SS   = (outCtxt, "repr (out,out)")
ctxtRepr Str  = (nullCtxt, "repr (VString repr)")

iHasCtxt = fst . ctxtRepr

-- | convert OType to data for instance heads
instrCtx S  = Just ("PVar out",1)
instrCtx SS = Just ("PVar out",2)
instrCtx C  = Just ("KVar out",1)
instrCtx V  = Just ("Varable out",1)
instrCtx MA = Just ("Nat d",1)
instrCtx _  = Nothing

oHasCtxt = isJust . instrCtx

-- | determine the proper outtype for instance decls
monoCtxt A    = "(ASig (S n))"
monoCtxt K    = "(KSig (S n))"
monoCtxt I    = "(INum (S n))"
monoCtxt F    = "(FSig (S n))"
monoCtxt U    = "()"
monoCtxt IK   = "(INum (S n), KSig (S n))"
monoCtxt KI   = "(KSig (S n), INum (S n))"
monoCtxt KK   = "(KSig (S n), KSig (S n))"
monoCtxt FF   = "(FSig (S n), FSig (S n))"
monoCtxt AA   = "(ASig (S n), ASig (S n))"
monoCtxt AK   = "(ASig (S n), KSig (S n))"
monoCtxt AAA  = "(ASig (S n), ASig (S n), ASig (S n))"
monoCtxt KKK  = "(KSig (S n), KSig (S n), KSig (S n))"
monoCtxt AAAA = "(ASig (S n), ASig (S n), ASig (S n), ASig (S n))"
monoCtxt KKKK = "(KSig (S n), KSig (S n), KSig (S n), KSig (S n))"
monoCtxt IIII = "(INum (S n), INum (S n), INum (S n), INum (S n))"
monoCtxt Str  = "(VString (S n))"
monoCtxt MA   = "d"
monoCtxt S    = "out"
monoCtxt SS   = "out"
monoCtxt C    = "out"
monoCtxt V    = "out"