content: {-# OPTIONS_GHC -Wall #-}
  {-# LANGUAGE OverloadedStrings #-}
  module MoveDocs
    ( move
    )
    where
  
  
  import Control.Monad
  import Control.Monad.Trans (liftIO)
  import Data.Aeson ((.:), (.:?))
  import qualified Data.Aeson as Json
  import qualified Data.Aeson.Types as Json
  import qualified Data.ByteString.Lazy as BS
  import qualified Data.Char as Char
  import qualified Data.List as List
  import qualified Data.Map as Map
  import qualified Data.Maybe as Maybe
  import qualified Data.Set as Set
  import qualified Data.Text as Text
  import System.FilePath ((</>))
  
  import qualified Crawl
  import qualified Elm.Compiler.Module as Module
  import qualified Elm.Compiler.Type as Type
  import qualified Elm.Docs as Docs
  import qualified Elm.Name as N
  import qualified Elm.Package as Pkg
  import qualified Task
  import qualified Json.Encode as Encode
  
  
  
  -- MOVE
  
  
  move :: Pkg.Name -> Pkg.Version -> Task.Transaction ()
  move pkg version =
    do  bits <- liftIO $ BS.readFile (Crawl.oldDir pkg version </> "documentation.json")
        case Json.eitherDecode bits of
          Left problem ->
            Task.bail $ "Problem parsing documentation.json:\n" ++ problem
  
          Right oldDocs ->
            let
              newDocs = List.map updateDocs oldDocs
            in
              liftIO $
                Encode.write (Crawl.newDir pkg version </> "docs.json") $
                  Encode.list Docs.encode newDocs
  
  
  updateDocs :: OldDocs -> Docs.Module
  updateDocs (OldDocs (Txt moduleName) (Txt comment) aliases types values) =
    Docs.Module
      { Docs._name = N.fromText moduleName
      , Docs._comment = comment
      , Docs._unions = Map.fromList (map toUnionPair types)
      , Docs._aliases = Map.fromList (map toAliasPair aliases)
      , Docs._values = Map.fromList (Maybe.mapMaybe toValuePair values)
      , Docs._binops = Map.fromList (Maybe.mapMaybe toBinopPair values)
      }
  
  
  toUnionPair :: Union -> (N.Name, Docs.Union)
  toUnionPair (Union (Txt name) (Txt comment) args cases) =
    ( N.fromText name, Docs.Union comment args cases )
  
  
  toAliasPair :: Alias -> (N.Name, Docs.Alias)
  toAliasPair (Alias (Txt name) (Txt comment) args tipe) =
    ( N.fromText name, Docs.Alias comment args tipe )
  
  
  toValuePair :: Value -> Maybe (N.Name, Docs.Value)
  toValuePair (Value (Txt name) (Txt comment) tipe _) =
    if Text.any isSymbol name then
      Nothing
    else
      Just (N.fromText name, Docs.Value comment tipe)
  
  
  toBinopPair :: Value -> Maybe (N.Name, Docs.Binop)
  toBinopPair (Value (Txt name) (Txt comment) tipe fix) =
    if Text.any isSymbol name then
      Just
        ( N.fromText name
        , case fix of
            Nothing ->
              Docs.Binop comment tipe Docs.Left (Docs.Precedence 9)
  
            Just (assoc, prec) ->
              Docs.Binop comment tipe assoc prec
        )
    else
      Nothing
  
  
  isSymbol :: Char -> Bool
  isSymbol char =
    Char.isSymbol char || Set.member char symbols
  
  
  symbols :: Set.Set Char
  symbols =
    Set.fromList "+-/*=.$<>:&|^?%#@~!"
  
  
  
  -- OLD DOCS
  
  
  newtype Txt =
    Txt Text.Text
  
  
  data OldDocs =
    OldDocs
      { _moduleName :: Txt
      , _comment :: Txt
      , _aliases :: [Alias]
      , _types :: [Union]
      , _values :: [Value]
      }
  
  
  data Alias =
    Alias
      { _aliasName :: Txt
      , _aliasComment :: Txt
      , _aliasArgs :: [N.Name]
      , _aliasType :: Type.Type
      }
  
  
  data Union =
    Union
      { _unionName :: Txt
      , _unionComment :: Txt
      , _unionArgs :: [N.Name]
      , _unionCases :: [(N.Name, [Type.Type])]
      }
  
  
  data Value =
    Value
      { _valueName :: Txt
      , _valueComment :: Txt
      , _valueType :: Type.Type
      , _valueFix :: Maybe (Docs.Associativity, Docs.Precedence)
      }
  
  
  
  -- JSON for OLD DOCS
  
  
  instance Json.FromJSON OldDocs where
      parseJSON (Json.Object obj) =
          OldDocs
              <$> obj .: "name"
              <*> obj .: "comment"
              <*> obj .: "aliases"
              <*> obj .: "types"
              <*> obj .: "values"
  
      parseJSON value =
          fail $ "Cannot decode OldDocs from: " ++ show (Json.encode value)
  
  
  instance Json.FromJSON Alias where
      parseJSON (Json.Object obj) =
          Alias
              <$> obj .: "name"
              <*> obj .: "comment"
              <*> obj .: "args"
              <*> obj .: "type"
  
      parseJSON value =
          fail $ "Cannot decode Alias from: " ++ show (Json.encode value)
  
  
  instance Json.FromJSON Union where
      parseJSON (Json.Object obj) =
          Union
              <$> obj .: "name"
              <*> obj .: "comment"
              <*> obj .: "args"
              <*> obj .: "cases"
  
      parseJSON value =
          fail $ "Cannot decode Union from: " ++ show (Json.encode value)
  
  
  instance Json.FromJSON Value where
      parseJSON (Json.Object obj) =
          Value
              <$> obj .: "name"
              <*> obj .: "comment"
              <*> obj .: "type"
              <*> (liftM2 (,) <$> obj .:? "associativity" <*> obj .:? "precedence")
  
      parseJSON value =
          fail $ "Cannot decode Value from: " ++ show (Json.encode value)
  
  
  instance Json.FromJSON Docs.Associativity where
    parseJSON value =
      case value of
        Json.String "left"  -> return Docs.Left
        Json.String "non"   -> return Docs.Non
        Json.String "right" -> return Docs.Right
        _ -> fail $ "Unknown precedence: " ++ show (Json.encode value)
  
  
  instance Json.FromJSON Docs.Precedence where
    parseJSON value =
      Docs.Precedence <$> Json.parseJSON value
  
  
  instance Json.FromJSON Txt where
    parseJSON (Json.String txt) =
      return $ Txt $
        Text.replace "\\u003c" "<" (Text.replace "\\u003e" ">" txt)
  
    parseJSON _ =
      fail "Need a STRING here."
  
  
  instance Json.FromJSON N.Name where
    parseJSON (Json.String txt) =
      return $ N.fromText txt
  
    parseJSON _ =
      fail "Need a STRING here."
  
  
  
  -- JSON for TYPES
  
  
  instance Json.FromJSON Type.Type where
    parseJSON value =
      let
        failure =
          fail $
            "Trying to decode a type string, but could not handle this value:\n"
            ++ show (Json.encode value)
      in
        case value of
          Json.String text ->
            maybe failure return (Type.fromText (Text.replace "\\u003e" ">" text))
  
          Json.Object obj ->
            fromObject obj
  
          _ ->
            failure
  
  
  fromObject :: Json.Object -> Json.Parser Type.Type
  fromObject obj =
    do  tag <- obj .: "tag"
        case (tag :: String) of
          "lambda" ->
              Type.Lambda
                <$> obj .: "in"
                <*> obj .: "out"
  
          "var" ->
              Type.Var
                <$> obj .: "name"
  
          "type" ->
              do  name <- obj .: "name"
                  return $
                    if name == "_Tuple0" then Type.Unit else Type.Type name []
  
          "app" ->
              do  func <- obj .: "func"
                  args <- obj .: "args"
                  case func of
                    Type.Type name [] ->
                      case args of
                        (a:b:cs) | N.startsWith "_Tuple" name ->
                          return $ Type.Tuple a b cs
  
                        _ ->
                          return $ Type.Type name args
  
                    Type.Unit | null args ->
                      return Type.Unit
  
                    _ ->
                      fail $ "Error on " ++ show (Json.encode obj)
  
          "record" ->
              Type.Record
                <$> obj .: "fields"
                <*> obj .: "extension"
  
          _ ->
              fail $ "Error when decoding type with tag: " ++ tag
  