Compile.hs

module Descript.BasicInj.Write.Compile
  ( compile
  , isFinal
  ) where

import Descript.BasicInj.Data.Value.Reg
import Descript.BasicInj.Data.Value.Gen
import Descript.BasicInj.Data.Atom
import Descript.Misc
import Core.DontForce
import Core.Data.List.Assoc hiding (Value)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import System.FilePath
import Prelude hiding (head)

-- | Converts a final (reduced) value with the given name into a
-- compiled package.
compile :: String -> Value () -> CompileResult
compile name' x
  = case compile' name' x of
         Failure () -> Failure $ NotFinal $ pprintStr x
         Success out -> Success out

-- | Whether a value is final. If so, it can be compiled.
-- Otherwise, if it can't be reduced anymore, it can't be compiled.
isFinal :: Value () -> Bool
isFinal = isSuccess . compile' dontForce

-- | Converts a final (reduced) value with the given name into a
-- compiled package.
compile' :: String -> Value () -> UResult Package
compile' name' (Value () [part]) = compilePart name' part
compile' _ (Value () _) = Failure ()

compilePart :: String -> Part () -> UResult Package
compilePart name' (PartPrim prim) = Success $ compilePrim name' prim
compilePart name' (PartRecord record) = compileRecord name' record

compilePrim :: String -> Prim () -> Package
compilePrim name' prim
  = Package
  { packageName = name' -<.> primExt prim
  , packageContents = PackageFile $ encodePrim prim
  }

compileRecord :: String -> Record () -> UResult Package
compileRecord name' (Record () head' properties')
  | head' == codeFSym = compileCode name' properties'
  | otherwise = Failure ()

compileCode :: String -> [Property ()] -> UResult Package
compileCode name' props
    = compileCode' name'
  <$> (valToText =<< maybeToUResult (glookup codeLangSym props))
  <*> (valToText =<< maybeToUResult (glookup codeContentSym props))

compileCode' :: String -> Text -> Text -> Package
compileCode' name' lang content
  = Package
  { packageName = name' -<.> languageExt (Text.unpack lang)
  , packageContents = PackageFile $ Text.encodeUtf8 content
  }

valToText :: Value () -> UResult Text
valToText (Value () [part]) = partToText part
valToText (Value () _) = Failure ()

partToText :: Part () -> UResult Text
partToText (PartPrim prim) = primToText prim
partToText (PartRecord _) = Failure ()

primToText :: Prim () -> UResult Text
primToText (PrimText () text) = Success text
primToText _ = Failure ()