content: -- Copyright (c) 2014 Contributors as noted in the AUTHORS file
  --
  -- This file is part of frp-arduino.
  --
  -- frp-arduino is free software: you can redistribute it and/or modify
  -- it under the terms of the GNU General Public License as published by
  -- the Free Software Foundation, either version 3 of the License, or
  -- (at your option) any later version.
  --
  -- frp-arduino is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  -- GNU General Public License for more details.
  --
  -- You should have received a copy of the GNU General Public License
  -- along with frp-arduino.  If not, see <http://www.gnu.org/licenses/>.
  
  module Arduino.DSL
      (
      -- * Core
        Action
      , Stream
      , Output
      , LLI
      , compileProgram
      , parseProgram
      , def
      , (=:)
      , prefixOutput
      , bootup
      , constStream
  
      -- * Expressions
      , Expression
  
      -- ** Bits
      , DAG.Bit
      , bitHigh
      , bitLow
      , flipBit
      , isHigh
      , boolToBit
  
      -- ** Bytes
      , DAG.Byte
  
      -- ** Words
      , DAG.Word
      , isEven
      , greater
  
      -- ** Byte arrays
      , formatString
      , formatNumber
  
      -- ** Tuples
      , pack2
      , pack6
      , unpack2
      , unpack6
      , output2
      , output6
  
      -- ** Misc
      , unit
      , isEqual
  
      -- ** Conditionals
      , if_
  
      -- * Streams
  
      -- ** Mapping
      , mapS
      , mapSMany
      , mapS2
  
      -- ** Merging
      , mergeS
  
      -- ** Filtering
      , filterS
  
      -- ** Folding
      , foldpS
  
      -- ** Flattering
      , flattenS
  
      -- ** Delaying
      , delay
  
      -- ** Syntactic sugar
      , (~>)
  
      -- * Low Level Instructions (LLI)
      -- | The glue between streams and harware.
      , createOutput
      , createInput
      , setBit
      , clearBit
      , writeBit
      , writeByte
      , writeWord
      , readBit
      , readWord
      , readTwoPartWord
      , waitBitSet
      , waitBitCleared
      , byteConstant
      , wordConstant
      , end
      ) where
  
  import Arduino.Internal.CodeGen.C (streamsToC)
  import Arduino.Internal.CodeGen.Dot(streamsToDot)
  import Control.Monad.State
  import Data.Char (ord)
  import qualified Arduino.Internal.DAG as DAG
  import System.Exit (exitFailure)
  
  data DAGState = DAGState
      { idCounter :: Int
      , dag       :: DAG.Streams
      , resources :: [String]
      , errors    :: [String]
      }
  
  type Action a = State DAGState a
  
  newtype Stream a = Stream { unStream :: Action DAG.Identifier }
  
  newtype Expression a = Expression { unExpression :: DAG.Expression }
  
  newtype Output a = Output { unOutput :: Stream a -> Action () }
  
  newtype LLI a = LLI { unLLI :: DAG.LLI }
  
  instance Num (Expression a) where
      (+) left right = Expression $ DAG.Add (unExpression left) (unExpression right)
      (-) left right = Expression $ DAG.Sub (unExpression left) (unExpression right)
      (*) left right = Expression $ DAG.Mul (unExpression left) (unExpression right)
      abs = error "abs not yet implemented"
      signum = error "signum not yet implemented"
      fromInteger value = Expression $ DAG.WordConstant $ fromIntegral value
  
  compileProgram :: Action a -> IO ()
  compileProgram action = do
      case parseProgram action of
          Right dag -> do
              writeFile "main.c" $ streamsToC dag
              writeFile "dag.dot" $ streamsToDot dag
          Left errors -> do
              putStrLn "Errors:"
              mapM_ putStrLn errors
              exitFailure
  
  parseProgram :: Action a -> Either [String] DAG.Streams
  parseProgram action =
      case errors dagState of
          [] -> Right $ dag dagState
          x  -> Left x
      where
          dagState = execState action (DAGState 1 DAG.emptyStreams [] [])
  
  def :: Stream a -> Action (Stream a)
  def stream = do
      name <- unStream stream
      return $ Stream $ return name
  
  (=:) :: Output a -> Stream a -> Action ()
  (=:) = unOutput
  
  infixr 0 =:
  
  prefixOutput :: (Stream b -> Stream a) -> Output a -> Output b
  prefixOutput fn output = Output $ \stream -> do
      output =: fn stream
  
  bootup :: Stream ()
  bootup = Stream $ addStream "bootup" DAG.Bootup
  
  constStream :: Expression a -> Stream a
  constStream value = mapS (const value) bootup
  
  output2 :: Output a1
          -> Output a2
          -> Output (a1, a2)
  output2 output1 output2 =
      Output $ \stream -> do
          x <- def stream
          output1 =: x ~> mapS (\x -> let (a, _) = unpack2 x in a)
          output2 =: x ~> mapS (\x -> let (_, a) = unpack2 x in a)
  
  output6 :: Output a1
          -> Output a2
          -> Output a3
          -> Output a4
          -> Output a5
          -> Output a6
          -> Output (a1, a2, a3, a4, a5, a6)
  output6 output1 output2 output3 output4 output5 output6 =
      Output $ \stream -> do
          x <- def stream
          output1 =: x ~> mapS (\x -> let (a, _, _, _, _, _) = unpack6 x in a)
          output2 =: x ~> mapS (\x -> let (_, a, _, _, _, _) = unpack6 x in a)
          output3 =: x ~> mapS (\x -> let (_, _, a, _, _, _) = unpack6 x in a)
          output4 =: x ~> mapS (\x -> let (_, _, _, a, _, _) = unpack6 x in a)
          output5 =: x ~> mapS (\x -> let (_, _, _, _, a, _) = unpack6 x in a)
          output6 =: x ~> mapS (\x -> let (_, _, _, _, _, a) = unpack6 x in a)
  
  (~>) :: Stream a -> (Stream a -> Stream b) -> Stream b
  (~>) stream fn = Stream $ do
      streamName <- unStream stream
      let outputStream = fn (Stream (return streamName))
      unStream $ outputStream
  
  -- | Similar to map in Haskell. \"S\" is for stream.
  mapS :: (Expression a -> Expression b) -> Stream a -> Stream b
  mapS fn stream = Stream $ do
      streamName <- unStream stream
      expressionStreamName <- addAnonymousStream (DAG.Map expression)
      addDependency streamName expressionStreamName
      where
          expression = unExpression $ fn $ Expression $ DAG.Input 0
  
  -- | Contrast with 'flattenS'.
  mapSMany :: (Expression a -> [Expression b]) -> Stream a -> Stream b
  mapSMany fn stream = Stream $ do
      streamName <- unStream stream
      expressionStreamName <- addAnonymousStream (DAG.MapMany expression)
      addDependency streamName expressionStreamName
      where
          expression = map unExpression $ fn $ Expression $ DAG.Input 0
  
  mapS2 :: (Expression a -> Expression b -> Expression c)
        -> Stream a
        -> Stream b
        -> Stream c
  mapS2 fn left right = Stream $ do
      leftName <- unStream left
      rightName <- unStream right
      expressionStreamName <- addAnonymousStream (DAG.Map expression)
      addDependency leftName expressionStreamName
      addDependency rightName expressionStreamName
      where
          expression = unExpression $ fn (Expression $ DAG.Input 0)
                                         (Expression $ DAG.Input 1)
  
  mergeS :: [Stream a] -> Stream a
  mergeS streams = Stream $ do
      names <- mapM unStream streams
      expressionStreamName <- addAnonymousStream (DAG.Merge $ DAG.Input 0)
      mapM_ (\x -> addDependency x expressionStreamName) names
      return expressionStreamName
  
  -- | Needs a tuple created with 'pack2'.
  delay :: Stream (a, DAG.Word) -> Stream a
  delay stream = Stream $ do
      streamName <- unStream stream
      expressionStreamName <- addAnonymousStream expression
      addDependency streamName expressionStreamName
      where
          expression = DAG.DelayMicroseconds (DAG.TupleValue 1 (DAG.Input 0))
                                             (DAG.TupleValue 0 (DAG.Input 0))
  
  filterS :: (Expression a -> Expression Bool) -> Stream a -> Stream a
  filterS fn stream = Stream $ do
      streamName <- unStream stream
      expressionStreamName <- addAnonymousStream filterTransform
      addDependency streamName expressionStreamName
      where
          filterTransform = DAG.Filter expression
          expression = unExpression $ fn $ Expression $ DAG.Input 0
  
  -- | Similar to fold in Haskell. \"S\" is for stream.
  --
  -- Inspired by <http://elm-lang.org/ Elm's>
  -- <http://package.elm-lang.org/packages/elm-lang/core/1.1.0/Signal#foldp foldp>.
  foldpS :: (Expression a -> Expression b -> Expression b)
         -> Expression b
         -> Stream a
         -> Stream b
  foldpS fn startValue stream = Stream $ do
      streamName <- unStream stream
      expressionStreamName <- addAnonymousStream foldTransform
      addDependency streamName expressionStreamName
      where
          foldTransform = DAG.Fold expression startExpression
          expression = unExpression $ fn (Expression $ DAG.Input 0)
                                         (Expression $ DAG.Input 1)
          startExpression = unExpression startValue
  
  -- | Contrast with 'mapSMany'.
  flattenS :: Stream [a] -> Stream a
  flattenS stream = Stream $ do
      streamName <- unStream stream
      expressionStreamName <- addAnonymousStream expression
      addDependency streamName expressionStreamName
      where
          expression = DAG.Flatten $ DAG.Input 0
  
  unit :: Expression ()
  unit = Expression $ DAG.Unit
  
  isEqual :: Expression a -> Expression a -> Expression Bool
  isEqual left right =
      Expression $ DAG.Equal (unExpression left) (unExpression right)
  
  if_ :: Expression Bool -> Expression a -> Expression a -> Expression a
  if_ condition trueExpression falseExpression =
      Expression (DAG.If (unExpression condition)
                         (unExpression trueExpression)
                         (unExpression falseExpression))
  
  greater :: Expression DAG.Word -> Expression DAG.Word -> Expression Bool
  greater left right = Expression $ DAG.Greater (unExpression left) (unExpression right)
  
  flipBit :: Expression DAG.Bit -> Expression DAG.Bit
  flipBit = Expression . DAG.Not . unExpression
  
  isEven :: Expression DAG.Word -> Expression Bool
  isEven = Expression . DAG.Even . unExpression
  
  boolToBit :: Expression Bool -> Expression DAG.Bit
  boolToBit = Expression . DAG.BoolToBit . unExpression
  
  isHigh :: Expression DAG.Bit -> Expression Bool
  isHigh = Expression . DAG.IsHigh . unExpression
  
  formatString :: String -> Expression [DAG.Byte]
  formatString = Expression . DAG.ListConstant . map (DAG.ByteConstant . fromIntegral . ord)
  
  formatNumber :: Expression DAG.Word -> Expression [DAG.Byte]
  formatNumber = Expression . DAG.NumberToByteArray . unExpression
  
  pack2 :: (Expression a1, Expression a2) -> Expression (a1, a2)
  pack2 (a1, a2) = Expression $ DAG.TupleConstant $
      [ unExpression a1
      , unExpression a2
      ]
  
  pack6 :: (Expression a1, Expression a2, Expression a3, Expression a4, Expression a5, Expression a6)
        -> Expression (a1, a2, a3, a4, a5, a6)
  pack6 (a1, a2, a3, a4, a5, a6) = Expression $ DAG.TupleConstant $
      [ unExpression a1
      , unExpression a2
      , unExpression a3
      , unExpression a4
      , unExpression a5
      , unExpression a6
      ]
  
  unpack2 :: Expression (a1, a2) -> (Expression a1, Expression a2)
  unpack2 expression =
      ( Expression $ DAG.TupleValue 0 (unExpression expression)
      , Expression $ DAG.TupleValue 1 (unExpression expression)
      )
  
  unpack6 :: Expression (a1, a2, a3, a4, a5, a6)
          -> (Expression a1, Expression a2, Expression a3, Expression a4, Expression a5, Expression a6)
  unpack6 expression =
      ( Expression $ DAG.TupleValue 0 (unExpression expression)
      , Expression $ DAG.TupleValue 1 (unExpression expression)
      , Expression $ DAG.TupleValue 2 (unExpression expression)
      , Expression $ DAG.TupleValue 3 (unExpression expression)
      , Expression $ DAG.TupleValue 4 (unExpression expression)
      , Expression $ DAG.TupleValue 5 (unExpression expression)
      )
  
  bitLow :: Expression DAG.Bit
  bitLow = Expression $ DAG.BitConstant DAG.Low
  
  bitHigh :: Expression DAG.Bit
  bitHigh = Expression $ DAG.BitConstant DAG.High
  
  addAnonymousStream :: DAG.Body -> Action DAG.Identifier
  addAnonymousStream body = do
      name <- buildUniqIdentifier "stream"
      addStream name body
  
  buildUniqIdentifier :: String -> Action DAG.Identifier
  buildUniqIdentifier baseName = do
      dag <- get
      let id = idCounter dag
      modify inc
      return $ baseName ++ "_" ++ show id
      where
          inc dag = dag { idCounter = idCounter dag + 1 }
  
  addStream :: DAG.Identifier -> DAG.Body -> Action DAG.Identifier
  addStream name body = do
      streamTreeState <- get
      unless (DAG.hasStream (dag streamTreeState) name) $ do
          mapM_ addResource (getResources body)
          modify $ insertStream $ DAG.Stream name [] body []
      return name
      where
          insertStream :: DAG.Stream -> DAGState -> DAGState
          insertStream stream x = x { dag = DAG.addStream (dag x) stream }
  
  getResources :: DAG.Body -> [String]
  getResources (DAG.Driver resources _ _) = resources
  getResources _                          = []
  
  addDependency :: DAG.Identifier -> DAG.Identifier -> Action DAG.Identifier
  addDependency source destination = do
      modify (\x -> x { dag = DAG.addDependency source destination (dag x) })
      return destination
  
  addResource :: String -> Action ()
  addResource name = do
      modify addResource'
      return ()
      where
          addResource' dagState =
              if name `elem` resources dagState
                  then dagState { errors = errors dagState ++ [name ++ " used twice"]}
                  else dagState { resources = name : (resources dagState) }
  
  createInput :: String -> LLI () -> LLI a -> Stream a
  createInput name initLLI bodyLLI =
      Stream $ addStream ("input_" ++ name) body
      where
          body = DAG.Driver [name] (unLLI initLLI) (unLLI bodyLLI)
  
  createOutput :: String -> LLI () -> (LLI a -> LLI ()) -> Output a
  createOutput name initLLI bodyLLI = Output $ \stream -> do
      streamName <- unStream stream
      outputName <- addAnonymousStream $ DAG.Driver [name] (unLLI initLLI) (unLLI (bodyLLI (LLI DAG.InputValue)))
      addDependency streamName outputName
      return ()
  
  setBit :: String -> String -> LLI a -> LLI a
  setBit register bit next = writeBit register bit (constBit DAG.High) next
  
  clearBit :: String -> String -> LLI a -> LLI a
  clearBit register bit next = writeBit register bit (constBit DAG.Low) next
  
  writeByte :: String -> LLI DAG.Byte -> LLI a -> LLI a
  writeByte register value next = LLI $ DAG.WriteByte register (unLLI value) (unLLI next)
  
  writeWord :: String -> LLI DAG.Word -> LLI a -> LLI a
  writeWord register value next = LLI $ DAG.WriteWord register (unLLI value) (unLLI next)
  
  readBit :: String -> String -> LLI DAG.Bit
  readBit register bit = LLI $ DAG.ReadBit register bit
  
  readWord :: String -> LLI a -> LLI DAG.Word
  readWord register next = LLI $ DAG.ReadWord register (unLLI next)
  
  readTwoPartWord :: String -> String -> LLI a -> LLI DAG.Word
  readTwoPartWord lowRegister highRegister next = LLI $ DAG.ReadTwoPartWord lowRegister highRegister (unLLI next)
  
  waitBitSet :: String -> String -> LLI a -> LLI a
  waitBitSet register bit next = waitBit register bit DAG.High next
  
  waitBitCleared :: String -> String -> LLI a -> LLI a
  waitBitCleared register bit next = waitBit register bit DAG.Low next
  
  waitBit :: String -> String -> DAG.Bit -> LLI a -> LLI a
  waitBit register bit value next = LLI $ DAG.WaitBit register bit value (unLLI next)
  
  writeBit :: String -> String -> LLI a -> LLI b -> LLI b
  writeBit register bit var next = LLI $ DAG.WriteBit register bit (unLLI var) (unLLI next)
  
  byteConstant :: DAG.Byte -> LLI DAG.Byte
  byteConstant = LLI . DAG.Const . show
  
  wordConstant :: DAG.Word -> LLI DAG.Word
  wordConstant = LLI . DAG.Const . show
  
  constBit :: DAG.Bit -> LLI DAG.Bit
  constBit = LLI . DAG.ConstBit
  
  end :: LLI ()
  end = LLI $ DAG.End
  