{-# language GeneralizedNewtypeDeriving #-}
{-# language NoMonomorphismRestriction #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}

module Main ( main ) where

import Control.Applicative ( (<**>), (<|>), Const(..), optional )
import Data.Foldable ( asum, foldl' )
import Data.Functor.Product ( Product(..) )
import Data.Functor.Identity ( Identity(..) )
import Data.Monoid ( Any(..), (<>) )
import Data.Function ( (&) )
import Data.Maybe ( fromMaybe )
import Data.Text.Lazy (Text)
import System.Environment ( getArgs )
import Data.String ( fromString )

import DhallToCabal

import qualified Data.Text.Lazy.IO as LazyText
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
import qualified Data.Text.Prettyprint.Doc.Symbols.Unicode as Pretty
import qualified Dhall
import qualified Dhall.Context
import qualified Dhall.Core as Dhall
import qualified Dhall.Core as Expr ( Expr(..), Var(..), shift )
import qualified Distribution.PackageDescription.PrettyPrint as Cabal
import qualified Options.Applicative as OptParse
import qualified System.IO



data Command
  = RunDhallToCabal DhallToCabalOptions
  | PrintType KnownType



data KnownType
  = Library
  | ForeignLibrary
  | Executable
  | Benchmark
  | TestSuite
  | Config
  | SourceRepo
  | RepoType
  | RepoKind
  | Compiler
  | OS
  | Extension
  | CompilerOptions
  | Arch
  | Language
  | License
  | BuildType
  | Package
  | VersionRange
  | Version
  deriving (Bounded, Enum, Eq, Ord, Read, Show)



data DhallToCabalOptions = DhallToCabalOptions
  { dhallFilePath :: Maybe String
  , explain :: Bool
  }



dhallToCabalOptionsParser :: OptParse.Parser DhallToCabalOptions
dhallToCabalOptionsParser =
  DhallToCabalOptions
    <$>
      optional
        ( OptParse.argument
            OptParse.str
            ( mconcat
                [ OptParse.metavar "<dhall input file>"
                , OptParse.help "The Dhall expression to convert to a Cabal file"
                ]
            )
        )
    <*>
      OptParse.flag
        False
        True
        ( mconcat
            [ OptParse.long "explain"
            , OptParse.help "Provide explanations to type Dhall syntax and type errors."
            ]
        )



printTypeParser :: OptParse.Parser KnownType
printTypeParser =
  OptParse.option OptParse.auto modifiers

  where

    modifiers =
      mconcat
        [ OptParse.long "print-type"
        , OptParse.help "Print out the description of a type. For a full description, try --print-type Package"
        , OptParse.metavar "TYPE"
        ]



runDhallToCabal :: DhallToCabalOptions -> IO ()
runDhallToCabal DhallToCabalOptions { dhallFilePath, explain } = do
  source <-
    case dhallFilePath of
      Nothing ->
        LazyText.getContents

      Just filePath ->
        LazyText.readFile filePath

  let
    fileName = fromMaybe "(STDIN)" dhallFilePath

  explaining
    ( dhallToCabal fileName source
        & fmap Cabal.showGenericPackageDescription
        >>= putStrLn
    )

  where

    explaining =
      if explain then Dhall.detailed else id



main :: IO ()
main = do
  command <-
    OptParse.execParser opts

  case command of
    RunDhallToCabal options ->
      runDhallToCabal options

    PrintType t ->
      printType t

  where

  parser =
    asum
      [ RunDhallToCabal <$> dhallToCabalOptionsParser
      , PrintType <$> printTypeParser
      ]

  opts =
    OptParse.info ( parser <**> OptParse.helper ) modifiers

  modifiers =
    mconcat
      [ OptParse.progDesc "Generate Cabal files from Dhall expressions"
      ]



-- Shamelessly taken from dhall-format

opts :: Pretty.LayoutOptions
opts =
  Pretty.defaultLayoutOptions
    { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }



printType :: KnownType -> IO ()
printType t = do
  Pretty.renderIO
    System.IO.stdout
    ( Pretty.layoutSmart opts
        ( Pretty.pretty factoredType )
    )

  putStrLn ""

  where

    dhallType t =
      case t of
        Config -> configRecordType
        Library -> Dhall.expected library
        ForeignLibrary -> Dhall.expected foreignLib
        Executable -> Dhall.expected executable
        Benchmark -> Dhall.expected benchmark
        TestSuite -> Dhall.expected testSuite
        SourceRepo -> Dhall.expected sourceRepo
        RepoType -> Dhall.expected repoType
        RepoKind -> Dhall.expected repoKind
        Compiler -> Dhall.expected compilerFlavor
        OS -> Dhall.expected operatingSystem
        Extension -> Dhall.expected extension
        CompilerOptions -> Dhall.expected compilerOptions
        Arch -> Dhall.expected arch
        Language -> Dhall.expected language
        License -> Dhall.expected license
        BuildType -> Dhall.expected buildType
        Package -> Dhall.expected genericPackageDescription
        VersionRange -> Dhall.expected versionRange
        Version -> Dhall.expected version

    letDhallType t =
      liftCSE ( fromString ( show t ) ) ( dhallType t )

    factoredType =
      foldl'
        ( flip letDhallType )
        ( dhallType t )
        [ minBound .. maxBound ]


liftCSE
  :: (Eq s, Eq a)
  => Text          -- ^ The name of the binding
  -> Expr.Expr s a -- ^ The common subexpression to lift
  -> Expr.Expr s a -- ^ The expression to remove a common subexpression from
  -> Expr.Expr s a
liftCSE name body expr =
  let
    v0 =
      Expr.V name 0

  in
    case go ( Expr.shift 1 v0 expr ) v0 of
      Pair ( Const ( Any False ) ) _ ->
        -- There was nothing to lift
        expr

      Pair _ ( Identity reduced ) ->
        -- We did manage to lift a CSE, so let bind it
        Expr.Let name Nothing body reduced

  where

    shiftName n v | n == name =
      shiftVar 1 v

    shiftName _ v =
        v

    shiftVar delta ( Expr.V name' n ) =
      Expr.V name' ( n + delta )

    go e v | e == body =
      Pair ( Const ( Any True ) ) ( Identity ( Expr.Var v ) )

    go e v =
      case e of
        Expr.Lam n t b ->
          Expr.Lam n t <$> go b ( shiftName n v )

        Expr.Pi n t b ->
          Expr.Pi n <$> go t v <*> go b ( shiftName n v )

        Expr.App f a ->
          Expr.App <$> go f v <*> go a v

        Expr.Let n t b e ->
          Expr.Let n t <$> go b v <*> go e ( shiftName n v )

        Expr.Annot a b ->
          Expr.Annot <$> go a v <*> go b v

        Expr.BoolAnd a b ->
          Expr.BoolAnd <$> go a v <*> go b v

        Expr.BoolOr a b ->
          Expr.BoolOr <$> go a v <*> go b v

        Expr.BoolEQ a b ->
          Expr.BoolEQ <$> go a v <*> go b v

        Expr.BoolNE a b ->
          Expr.BoolNE <$> go a v <*> go b v

        Expr.BoolIf a b c ->
          Expr.BoolIf <$> go a v <*> go b v <*> go c v

        Expr.NaturalPlus a b ->
          Expr.NaturalPlus <$> go a v <*> go b v

        Expr.NaturalTimes a b ->
          Expr.NaturalTimes <$> go a v <*> go b v

        Expr.ListAppend a b ->
          Expr.ListAppend <$> go a v <*> go b v

        Expr.Combine a b ->
          Expr.Combine <$> go a v <*> go b v

        Expr.Prefer a b ->
          Expr.Prefer <$> go a v <*> go b v

        Expr.TextAppend a b ->
          Expr.TextAppend <$> go a v <*> go b v

        Expr.ListLit t elems ->
          Expr.ListLit
            <$> ( traverse ( `go` v ) t )
            <*> ( traverse ( `go` v ) elems )

        Expr.OptionalLit t elems ->
          Expr.OptionalLit
            <$> go t v
            <*> ( traverse ( `go` v ) elems )

        Expr.Record fields ->
          Expr.Record <$> traverse ( `go` v ) fields

        Expr.RecordLit fields ->
          Expr.RecordLit <$> traverse ( `go` v ) fields

        Expr.Union fields ->
          Expr.Union <$> traverse ( `go` v ) fields

        Expr.UnionLit n a fields ->
          Expr.UnionLit n <$> go a v <*> traverse ( `go` v ) fields

        Expr.Merge a b t ->
          Expr.Merge <$> go a v <*> go b v <*> traverse ( `go` v ) t

        Expr.Constructors e ->
          Expr.Constructors <$> go e v

        Expr.Field e f ->
          Expr.Field <$> go e v <*> pure f

        Expr.Note s e ->
          Expr.Note s <$> go e v

        Expr.Embed{} ->
          pure e

        Expr.Const{} ->
          pure e

        Expr.Var{} ->
          pure e

        Expr.Bool{} ->
          pure e

        Expr.BoolLit{} ->
          pure e

        Expr.Natural{} ->
          pure e

        Expr.NaturalLit{} ->
          pure e

        Expr.NaturalFold{} ->
          pure e

        Expr.NaturalBuild{} ->
          pure e

        Expr.NaturalIsZero{} ->
          pure e

        Expr.NaturalEven{} ->
          pure e

        Expr.NaturalOdd{} ->
          pure e

        Expr.NaturalToInteger{} ->
          pure e

        Expr.NaturalShow{} ->
          pure e

        Expr.Integer{} ->
          pure e

        Expr.IntegerShow{} ->
          pure e

        Expr.IntegerLit{} ->
          pure e

        Expr.Double{} ->
          pure e

        Expr.DoubleShow{} ->
          pure e

        Expr.DoubleLit{} ->
          pure e

        Expr.Text{} ->
          pure e

        Expr.TextLit{} ->
          pure e

        Expr.List ->
          pure e

        Expr.ListBuild ->
          pure e

        Expr.ListFold ->
          pure e

        Expr.ListLength ->
          pure e

        Expr.ListHead ->
          pure e

        Expr.ListLast ->
          pure e

        Expr.ListIndexed ->
          pure e

        Expr.ListReverse ->
          pure e

        Expr.Optional ->
          pure e

        Expr.OptionalFold ->
          pure e

        Expr.OptionalBuild ->
          pure e