annah-1.0.0: exec/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Annah.Core (Data(..), Expr(..), Type(..))
import Control.Applicative ((<|>))
import Control.Exception (Exception, throwIO)
import Control.Monad (forM_)
import Data.Monoid (mempty)
import Data.Text.Lazy (fromStrict)
import Filesystem.Path (FilePath, (</>))
import Morte.Core (Path(..), Var(..))
import Options.Applicative
import Prelude hiding (FilePath)
import System.IO (stderr)

import qualified Annah.Core                as Annah
import qualified Annah.Parser              as Annah
import qualified Data.Text.Lazy            as Text
import qualified Data.Text.Lazy.IO         as Text
import qualified Filesystem
import qualified Filesystem.Path.CurrentOS as Filesystem
import qualified Morte.Core                as Morte
import qualified Morte.Import              as Morte

throws :: Exception e => Either e a -> IO a
throws (Left  e) = throwIO e
throws (Right r) = return r

data Mode = Default | Compile FilePath | Desugar | Types

parser :: Parser Mode
parser
    =   subparser
        (   command "compile"
            (info (helper <*> (Compile <$> parseFilePath))
                (   fullDesc
                <>  header "annah compile - Compile Annah code"
                <>  progDesc "Compile an Annah program located at the given \
                             \file path.  Prefer this subcommand over reading \
                             \from standard input when you want remote \
                             \references to be resolved relative to that \
                             \file's path"
                )
            )
        <>  metavar "compile"
        )
    <|> subparser
        (   command "desugar"
            (info (helper <*> pure Desugar)
                (   fullDesc
                <>  header "annah desugar - Desugar Annah code"
                <>  progDesc "Desugar an Annah program to the equivalent Morte \
                             \program, reading the Annah program from standard \
                             \input and writing the Morte program to standard \
                             \output."
                )
            )
        <>  metavar "desugar"
        )
    <|> subparser
        (   command "types"
            (   info (helper <*> pure Types)
                (   fullDesc
                <>  header "annah types - Compile an Annah datatype definition"
                <>  progDesc "Translate an Annah datatype definition to the \
                             \equivalent set of files, reading the datatype \
                             \definition from standard input.  This creates \
                             \one output directory for each type with one file \
                             \underneath each directory per data constructor \
                             \associated with that type."
                )
            )
        <>  metavar "types"
        )
    <|> pure Default
  where
    parseFilePath =
        fmap Filesystem.decodeString
            (strArgument (metavar "FILEPATH" <> help "Path to file to compile"))

main :: IO ()
main = do
    mode <- execParser $ info (helper <*> parser)
        (   fullDesc
        <>  header "annah - A strongly typed, purely functional language"
        <>  progDesc "Annah is a medium-level language that is a superset of \
                     \Morte.  Use this compiler to desugar Annah code to Morte \
                     \code."
        )
    case mode of
        Default -> do
            txt <- Text.getContents
            ae  <- throws (Annah.exprFromText txt)
            let me = Annah.desugar ae
            -- Only statically link the Morte expression for type-checking
            me' <- Morte.load Nothing me
            mt  <- throws (Morte.typeOf me')
            -- Return the dynamically linked Morte expression
            Text.putStrLn (Morte.pretty (Morte.normalize me))
        Compile file -> do
            txt <- Text.readFile (Filesystem.encodeString file)
            ae  <- throws (Annah.exprFromText txt)
            let me = Annah.desugar ae
            -- Only statically link the Morte expression for type-checking
            me' <- Morte.load (Just (File file)) me
            mt  <- throws (Morte.typeOf me')
            -- Return the dynamically linked Morte expression
            Text.putStrLn (Morte.pretty (Morte.normalize me))
        Desugar -> do
            txt <- Text.getContents
            ae  <- throws (Annah.exprFromText txt)
            Text.putStrLn (Morte.pretty (Annah.desugar ae))
        Types -> do
            -- TODO: Handle duplicate type and data constructor names
            txt <- Text.getContents
            ts  <- throws (Annah.typesFromText txt)
            let write file txt =
                    Filesystem.writeTextFile file (Text.toStrict txt <> "\n")
            let named = Filesystem.fromText . Text.toStrict
            forM_ ts (\t -> do
                let typeDir = named (typeName t)
                let typeAnnahFile = named (typeName t <> ".annah")
                let typeMorteFile = typeDir </> "@"
                let foldAnnahFile = typeDir </> named (typeFold t <> ".annah")
                let foldMorteFile = typeDir </> named (typeFold t)

                Filesystem.createDirectory True typeDir
                write typeAnnahFile (txt <> "in   " <> typeName t)
                let e0 = Family ts (Var (V (typeName t) 0))
                let typeTxt = Morte.pretty (Morte.normalize (Annah.desugar e0))
                write typeMorteFile typeTxt

                if typeFold t /= "_"
                    then do
                        write foldAnnahFile (txt <> "in   " <> typeFold t)
                        let e1 = Family ts (Var (V (typeFold t) 0))
                        let foldTxt =
                                Morte.pretty (Morte.normalize (Annah.desugar e1))
                        write foldMorteFile foldTxt
                    else return ()

                forM_ (typeDatas t) (\d -> do
                    let dataAnnahName = named (dataName d <> ".annah")
                    let dataMorteName = named (dataName d)
                    let dataAnnahFile = typeDir </> dataAnnahName
                    let dataMorteFile = typeDir </> dataMorteName

                    write dataAnnahFile (txt <> "in   " <> dataName d)

                    let e2 = Family ts (Var (V (dataName d) 0))
                    let dataTxt =
                            Morte.pretty (Morte.normalize (Annah.desugar e2))
                    write dataMorteFile dataTxt ) )