CFtoAbstract.hs

{-# LANGUAGE TemplateHaskell #-}
{-
    BNF Converter: Abstract syntax Generator
    Copyright (C) 2004  Author:  Markus Forberg

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Language.LBNF.CFtoAbstract (cf2Abstract) where

import Language.Haskell.TH

import Language.LBNF.CF


-- to produce a Haskell module
cf2Abstract :: CF -> Q ([Dec],[Dec])
cf2Abstract cf0 = do
  d1 <- sequence $ map prData $ cf2data cf0
  d2 <- sequence $ map (prSpecialData cf0) (specialCats cf0) 
--  d3 <- if hasAq cf0
--    then do
--      let cf = resolveAq cf0
      -- d3a <- sequence $ map (prSpecialData cf) (specialCats cf) 
--      d3b <- sequence $ map prData $ cf2data cf
      -- d3c <- transl cf0
      -- d3d <- lifts cf
--      return $ d3b
--    else return []
  
  return (d1, d2)



fixname :: String -> TypeQ
fixname ('[':xs) = appT listT $ conT $ mkName $ init xs
fixname xs = conT $ mkName xs
  
prData :: Data -> Q Dec
prData (cat,rules) = 
  dataD (return []) (mkName cat) [] (map cons rules) deriv where
    cons (fun,cats) = normalC (mkName fun) $ map typ cats
    typ cat = strictType notStrict $ fixname cat
    deriv = [mkName "Eq",mkName "Ord",mkName "Show"]

prSpecialData :: CF -> Cat -> Q Dec
prSpecialData cf cat =
  newtypeD (return []) (mkName cat) [] con deriv where
    con = normalC (mkName cat) $ [typ]
    typ = strictType notStrict $ contentSpec cf cat
    deriv = [mkName "Eq",mkName "Ord",mkName "Show"]

contentSpec :: CF -> Cat -> Q Type
contentSpec cf cat = if isPositionCat cf cat 
  then [t|((Int,Int),String)|] 
  else [t|String|]


-- aqName :: Bool -> String -> Name
-- aqName False s = 


-- transl cf = return []

-- lifts cf = return []