sexp.elm

import Char
import Dict
import Dict (Dict)
-- import Graphics.Element (..)
-- import Graphics.Input.Field as Field
-- import Graphics.Input (..)
import Html
import Html (..)
import Html.Attributes (..)
import Html.Events (..)
import List
import Maybe
import Signal
import String
import Result

-- import Native.Graph


-- charCodeAt : Int -> String -> Maybe Char
-- charCodeAt = Native.Graph.charCodeAt

-- MODEL

type alias Symbol = (Int, String)

type alias SymTable = {
  max: Int,
  tbl: Dict String Int
}

emptyTable : SymTable
emptyTable = { max = 0, tbl = Dict.empty }

symbol : SymTable -> String -> (SymTable, Symbol)
symbol t s = case Dict.get s t.tbl of
  Just i -> (t, (i,s))
  Nothing -> ({ t | tbl <- Dict.insert s (t.max + 1) t.tbl, max <- t.max + 1 }, (t.max + 1,s))

symname : Symbol -> String
symname (i, s) = s

type alias Constructor = String

type alias Variable = String

type alias TyDec = String

type alias TyDecs = {
  baseTypes: Dict TyDec (Dict Symbol (List Type)),
  index: Dict Symbol (TyDec, List Type)
}

type alias BaseIndex = Dict Symbol TyDec

type Type
  = Base TyDec
  -- | Func (Type, Type)

type alias BaseType = Dict Constructor (List Type)

type alias BaseTypes = Dict TyDec BaseType

baseTypes : BaseTypes
baseTypes = Dict.fromList
  [ ("bool", Dict.fromList [("True", []), ("False", [])])
  , ("list", Dict.fromList [("Nil", []), ("Cons", [Base "bool", Base "list"])])
  ]

foo : () -> ()
foo x = x

declType : SymTable -> TyDecs -> (TyDec, BaseType) -> (SymTable, TyDecs)
declType t { baseTypes, index } (c, new) =
  let (t', new', idx') = Dict.foldl (\c' ty (t, new, idx) ->
    let (t', s) = symbol t c'
    in (t', Dict.insert s ty new, Dict.insert s (c, ty) idx)) (t, Dict.empty, index) new
  in (t', { baseTypes = Dict.insert c new' baseTypes, index = idx' })

declTypes : SymTable -> BaseTypes -> (SymTable, TyDecs)
declTypes symbolTable baseTypes
  = Dict.foldl (\ty -> \c -> \(t, new) -> declType t new (ty, c))
                 (symbolTable, { baseTypes = Dict.empty, index = Dict.empty }) baseTypes

type Term
  = Con (Constructor, List Term, Type)
  -- = Var (Variable, Type)
  -- | Abs (Variable, Type, Term)
  -- | App (Term, Term, Type)
  -- | Con (Constructor, List Term, Type)
  -- | Case (Term, Dict Constructor (List Variable, Term), Type)
  -- | Fix Term

typeOf : Term -> Type
typeOf term = case term of
  Con (_, _, ty) -> ty

type alias Model = {
  term: String -- Field.Content
}

type Token
  = LParen
  | RParen
  | VBar
  | Eq
  | Ident Symbol
  | TyIdent Symbol
  | KwType

type AbsExp
  = SExp (List AbsExp)
  | Atom Symbol

-- scan : SymTable -> String -> Result () (SymTable, List Token)
-- scan tbl s =
--   let isWhitespace ch =
--         ch == ' ' || ch == '\n' || ch == '\r' || ch == '\t' || ch == '\v'
--       isIdent ch =
--         Char.isUpper(ch) || Char.isLower(ch) || Char.isDigit(ch) || ch == '_'
--       skip i = Maybe.andThen (charCodeAt i s) (\ch ->
--         if isWhitespace ch then skip (i + 1) else Just (ch, i))
--       buildIdent i = case charCodeAt i s of
--         Just ch -> if isIdent ch then buildIdent (i + 1)
--                                  else i
--         Nothing -> i
--       build tbl i toks = case charCodeAt i s of
--         --case skip i of
--         Just ch ->
--           if isWhitespace ch
--              then build tbl (i + 1) toks
--              else case ch of
--                ' ' -> build tbl (i + 1) toks
--                '(' -> build tbl (i + 1) <| LParen :: toks
--                ')' -> build tbl (i + 1) <| RParen :: toks
--                _ -> if | Char.isUpper ch -> let i' = buildIdent (i + 1)
--                                                 id = String.slice i i' s
--                                                 (tbl', id') = symbol tbl id
--                                             in build tbl' i' ((Ident id') :: toks)
--                        | Char.isLower ch -> let i' = buildIdent (i + 1) 
--                                                 id = String.slice i i' s
--                                                 (tbl', id') = symbol tbl id
--                                             in build tbl' i' ((Ident id') :: toks)
--                        | otherwise -> Err ()
--         Nothing -> Ok (tbl, List.reverse toks)
--   in
--       build tbl 0 []
scan : SymTable -> String -> Result () (SymTable, List Token)
scan tbl s =
  let isIdent ch =
        Char.isUpper(ch) || Char.isLower(ch) || Char.isDigit(ch) || ch == '_'
      skip = String.uncons << String.trimLeft
      buildIdent s id = case String.uncons s of
        Just (ch, s') -> if isIdent ch then buildIdent s' <| String.cons ch id
                                       else (String.reverse id, s)
        Nothing -> (String.reverse id, s)
      build tbl s toks = case skip s of
        Just (ch, s') -> case ch of
          '(' -> build tbl s' <| LParen :: toks
          ')' -> build tbl s' <| RParen :: toks
          '=' -> build tbl s' <| Eq :: toks
          '|' -> build tbl s' <| VBar :: toks
          _ -> if | Char.isUpper ch -> let (id, s'') = buildIdent s' <| String.fromChar ch
                                           (tbl', id') = symbol tbl id
                                       in build tbl' s'' <| (Ident id') :: toks
                  | Char.isLower ch -> let (id, s'') = buildIdent s' <| String.fromChar ch
                                           (tbl', id') = symbol tbl id
                                       in build tbl' s'' <| (case id of
                                           "type" -> KwType
                                           _ -> TyIdent id') :: toks
                  | otherwise -> Err ()
        Nothing -> Ok (tbl, List.reverse toks)
  in
      build tbl s []

parse : List Token -> Result () (AbsExp, BaseTypes)
parse toks =
  let parse' toks exps atoms decls = case toks of
    LParen::toks -> parse' toks (atoms::exps) [] decls
    RParen::toks -> case exps of
      atoms'::exps -> parse' toks exps ((SExp <| List.reverse atoms)::atoms') decls
      _ -> Err ()
    (Ident id)::toks -> parse' toks exps ((Atom id)::atoms) decls
    KwType::(TyIdent ty)::Eq::(Ident cons)::toks ->
      if List.length exps == 0
         then let foo=0
                  parseTyDec toks' base cons tys = case toks' of
                    (TyIdent t)::toks'' ->
                      parseTyDec toks'' base cons (Base (symname t)::tys)
                    VBar::(Ident cons')::toks'' ->
                      parseTyDec toks''
                                 {- TODO: Detect conflicts. -}
                                 (Dict.insert cons (List.reverse tys) base)
                                 (symname cons') []
                    toks'' -> (Dict.insert (symname ty) (Dict.insert cons (List.reverse tys) base) decls, toks'')
                  (decls', toks') = parseTyDec toks Dict.empty (symname cons) []
              in parse' toks' exps atoms decls'
         else Err ()
    [] -> if List.length exps == 0 then Ok <| (List.reverse atoms, decls)
                                   else Err ()
    _ -> Err ()
  in
     Result.map (\(exps, decls) -> (
       case exps of
         [exp] -> exp
         _ -> SExp exps,
       decls)) (parse' toks [] [] Dict.empty)

infer : TyDecs -> AbsExp -> Result () Term
infer { index, baseTypes } exp =
  let inferList bt tl terml = case (bt, tl) of
    ([], []) -> Ok (List.reverse terml)
    (b::bl, t::tl) ->
      Result.andThen (infer { index = index, baseTypes = baseTypes } b) (\term' ->
        if typeOf term' == t then inferList bl tl (term'::terml)
                    else Err ())
    _ -> Err ()
  in
    case exp of
      Atom s -> case Dict.get s index of
        Just (ty, bt) ->
          if (List.length bt) == 0 then Ok (Con (symname s, [], Base ty))
                                   else Err ()
        Nothing -> Err ()
      SExp (Atom s::tl) -> case Dict.get s index of
        Just (ty, bt) -> Result.map (\terms -> Con (symname s, terms, Base ty))
                                    (inferList tl bt [])
        Nothing -> Err ()
      _ -> Err ()

-- UPDATE

type Action
  = SetTerm String -- Field.Content
  | NoOp

update : Action -> Model -> Model
update action model = case action of
  SetTerm term -> { model - term | term = term }
  NoOp -> model

-- VIEW

renderWorkflow : TyDecs -> Result () Term -> Html
renderWorkflow { baseTypes } t =
  let render term = case term of
    Con (ctor, ts, ty) -> case ty of
      Base "bool" -> input [type' "checkbox"] [] --checkbox (Signal.send (Signal.channel False)) True
      Base bty ->
        case Dict.get bty baseTypes of
          Just bty -> case Dict.toList bty of
            [entry] ->
              fieldset []
                        (legend [] [text ctor] :: 
                        List.map render ts)
            [] -> text "Oops"
            entries -> let options = List.map (\(k, v) -> (symname k, v)) entries
                       in --   [ dropDown (Signal.send (Signal.channel (List.map typeOf ts))) options
                          fieldset []
                          (  legend [] [(select [] <| List.map (\(k, v) -> option [value k, selected (k == ctor)] [text k]) options)]
                          :: List.map render ts)
                                
          Nothing -> text <| "Failed to fetch type" ++ bty ++ ".  This is a bug."
  in
     case t of
       Ok term -> render term
       Err e -> text <| "Could not render workflow due to an error: " ++ (toString e)

view : Model -> Html
view model =
  let foo = 1
      (symbolTable, toks) = case scan emptyTable model.term of
        Ok (symbolTable, toks) -> (symbolTable, Ok toks)
        Err e -> (emptyTable, Err e)
      (exp, decls) = case Result.andThen toks parse of
        Ok (exp, decls) -> (Ok exp, Dict.union baseTypes decls)
        Err e -> (Err e, baseTypes)
      (_, tydecs) = declTypes symbolTable decls
      term = Result.andThen exp (infer tydecs)
  in
    div []
    [ div []
        [ -- container 40 40 middle Field.field Field.defaultStyle (Signal.send actionChannel << SetTerm) "Type here!" model.term
          textarea [cols 80, rows 25, value <| model.term, on "input" targetValue <| \value ->
            Signal.send actionChannel <| SetTerm value] []
        , Html.form []
          [ text "Workflow"
          , renderWorkflow tydecs term
          ]
        ]
        , div []
          [ text "Declarations"
          , decls |> toString |> text
          ]
        , div []
          [ text "Scanning"
          , toks |> toString |> text
          ]
        , div []
          [ text "Parsing"
          , exp |> toString |> text
          ]
        , div []
          [ text "Inferring"
          , term |> toString |> text
          ]
    ]

--- SIGNALS

main : Signal Html
main = Signal.map view model

model : Signal Model
model =
  Signal.foldp update {
    term = "True" -- Field.noContent
  } <| Signal.subscribe actionChannel

actionChannel : Signal.Channel Action
actionChannel = Signal.channel <| SetTerm "True" -- Field.noContent